home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 101-125 / disk_104 / analyticalc / src / analysrc.arc / AnalyO.Ftn < prev    next >
Text File  |  1987-10-06  |  95KB  |  3,172 lines
  1. c -h- acini1.fnw    Fri Aug 22 12:55:08 1986    
  2. C PORTACALC MAIN PROGRAM
  3. C SPREAD SHEET DRIVER PROGRAM
  4. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  5. C ALL RIGHTS RESERVED
  6. C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
  7. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  8. C SCREEN.
  9.     SUBROUTINE INITA1(KMAP,KWID,ICODE)
  10. C
  11.     InTeGer*4 PRL(6)
  12.         CHARACTER*1 NOWRAP ( 2 )
  13.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  14.     INTEGER*4 VNLT
  15.     INTEGER IFCW
  16. c    EXTERNAL LCWRQQ
  17.     DIMENSION FORM(128),FVLD(1,1)
  18. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  19. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  20. C SO INITIALLY IGNORE.
  21. C ***<<<< RDD COMMON START >>>***
  22.     InTeGer*4 RRWACT,RCLACT
  23. C    COMMON/RCLACT/RRWACT,RCLACT
  24.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  25.      1  IDOL7,IDOL8
  26. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  27. C     1  IDOL7,IDOL8
  28.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  29. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  30.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  31. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  32. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  33. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  34.     InTeGer*4 KLVL
  35. C    COMMON/KLVL/KLVL
  36.     InTeGer*4 IOLVL,IGOLD
  37. C    COMMON/IOLVL/IOLVL
  38. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  39. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  40.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  41.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  42.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  43. C ***<<< RDD COMMON END >>>***
  44. CCC    InTeGer*4 RRWACT,RCLACT
  45. CCC    COMMON/RCLACT/RRWACT,RCLACT
  46. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  47. CCC     1  IDOL7,IDOL8
  48. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  49. CCC     1  IDOL7,IDOL8
  50. CCC    InTeGer*4 LLCMD,LLDSP
  51. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  52. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  53.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  54.     COMMON/D2R/NRDSP,NCDSP
  55. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  56. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  57. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  58. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  59.     CHARACTER*1 FORM2(4)
  60. C ***<<< XVXTCD COMMON START >>>***
  61.     CHARACTER*1 OARRY(100)
  62.     InTeGer*4 OSWIT,OCNTR
  63. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  64. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  65.     InTeGer*4 IPS1,IPS2,MODFLG
  66. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  67.        InTeGer*4 XTCFG,IPSET,XTNCNT
  68.        CHARACTER*1 XTNCMD(80)
  69. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  70. C VARY FLAG ITERATION COUNT
  71.     INTEGER KALKIT
  72. C    COMMON/VARYIT/KALKIT
  73.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  74.     InTeGer*4 RCMODE,IRCE1,IRCE2
  75. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  76. C     1  IRCE2
  77. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  78. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  79. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  80. C RCFGX ON.
  81. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  82. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  83. C  AND VM INHIBITS. (SETS TO 1).
  84.     INTEGER*4 FH
  85. C FILE HANDLE FOR CONSOLE I/O (RAW)
  86. C    COMMON/CONSFH/FH
  87.     CHARACTER*1 ARGSTR(52,4)
  88. C    COMMON/ARGSTR/ARGSTR
  89.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  90.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  91.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  92.      3  IRCE2,FH,ARGSTR
  93. C ***<<< XVXTCD COMMON END >>>***
  94. CCC    InTeGer*4 OSWIT,OCNTR
  95. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  96. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  97.     InTeGer*4 TYPE(1,1),VLEN(9)
  98. CCC    InTeGer*4 KLVL
  99. CCC    COMMON/KLVL/KLVL
  100. CCC    InTeGer*4 IOLVL
  101. CCC    COMMON/IOLVL/IOLVL
  102. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  103. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  104.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  105.     REAL*8 XXV(1,1)
  106.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  107.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  108. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  109.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  110.     CHARACTER*12 CDVFMT
  111.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  112.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  113.     COMMON/DEFVBX/DVFMT
  114.     CHARACTER*1 NMSH(80)
  115.     CHARACTER*80 NMSH80
  116.     EQUIVALENCE(NMSH80(1:1),NMSH(1))
  117.     COMMON/NMSH/NMSH
  118. CCC    InTeGer*4 IPS1,IPS2,MODFLG
  119. CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
  120. CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
  121. CCC       CHARACTER*1 XTNCMD(80)
  122. CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  123. C VARY FLAG ITERATION COUNT
  124. CCC    INTEGER KALKIT
  125. CCC    COMMON/VARYIT/KALKIT
  126. CCC    InTeGer*4 FORMFG,RCFGX,PZAP
  127. CCC    InTeGer*4 RCONE,RCMODE,IRCE1,IRCE2
  128. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  129. CCC     1  IRCE1,IRCE2
  130. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  131. C RCFGX FLAGS WHETHER TO DO AUTO RECALC
  132. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED
  133.     InTeGer*4 CWIDS(20)
  134. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY.
  135.     INTEGER*4 I4TMP
  136. C ***<<< NULETC COMMON START >>>***
  137.     InTeGer*4 ICREF,IRREF
  138. C    COMMON/MIRROR/ICREF,IRREF
  139.     InTeGer*4 MODPUB,LIMODE
  140. C    COMMON/MODPUB/MODPUB,LIMODE
  141.     InTeGer*4 KLKC,KLKR
  142.     REAL*8 AACP,AACQ
  143. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  144.     InTeGer*4 NCEL,NXINI
  145. C    COMMON/NCEL/NCEL,NXINI
  146.     CHARACTER*1 NAMARY(20,301)
  147. C    COMMON/NMNMNM/NAMARY
  148.     InTeGer*4 NULAST,LFVD
  149. C    COMMON/NULXXX/NULAST,LFVD
  150.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  151.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  152. C ***<<< NULETC COMMON END >>>***
  153. CCC    InTeGer*4 ICREF,IRREF
  154. CCC    COMMON/MIRROR/ICREF,IRREF
  155. C SETS NUMBER OF COLS TO ADD ON ROW OVERFLOW, ROWS TO ADD ON COL OVERFLOW
  156. C FOR CELL ALIASING.
  157.     REAL*8 DVS(20,75)
  158.     COMMON /FVLDC/FVLD
  159. C FOLLOWING SUPPORT VVARY OVERLAY:
  160.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  161.     LOGICAL*4 LEXIST
  162.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  163.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  164.     COMMON/DSPCMN/DVS,CWIDS
  165.     CHARACTER*1 CHR
  166.     character*20 fwt
  167.     EQUIVALENCE(FWT(1:1),CHR)
  168. C DISABLE FLOATING EXCEPTIONS
  169. C    CALL LCWRQQ(IFCW)
  170. C (MOVED LCWRQQ CALL TO MAIN)
  171.     IDOL7=1
  172. C ENABLE SCROLLING INITIALLY
  173. C ZERO "SAVED DISPLAY VALUES" FIRST...
  174.     DO 35 N=1,75
  175.     DO 35 NN=1,20
  176. 35    DVS(NN,N)=0.
  177.     MODFLG=1
  178. C INITIALLY IN NON ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
  179. C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
  180. C SETUP INITIAL DISPLAY LIMITS ACTUALLY USED.
  181.     RRWACT=1
  182.     RCLACT=1
  183.     IOLVL=11
  184.     DRWV=7
  185.     DCLV=19
  186.     LLCMD=22
  187.     LLDSP=23
  188.     ICREF=10
  189.     IRREF=50
  190. C SET INCREMENTS TO 1/6 OF TOTAL FOR STARTERS.
  191.     KLVL=1
  192.     KALKIT=0
  193.     IRCE1=0
  194.     IRCE2=0
  195.     RCMODE=2
  196.     ICODE=0
  197.     idol3=0
  198.     idol4=0
  199.     idol5=20000
  200.     idol6=20000
  201.     RCFGX=0
  202.     FORMFG=0
  203. C      CALL GETADR ( PRL, NOWRAP )
  204.       PRL ( 2 ) = 2
  205. c    OPEN(6,FILE='CON:',STATUS='NEW',FORM='FORMATTED')
  206.     OPEN(11,FILE='CON:20/260/450/30/Analy Command Inputs',
  207.      1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
  208.     OPEN(18,FILE='CON:20/210/450/30/Analy Cmd Prompts',
  209.      1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
  210. C LOOK FOR 'ACINIT.PRM' INITIALIZER FILE. IF ONE FOUND, READ IT.
  211. C IF NOT, ASK AT CONSOLE FOR SINGLE/DBL PRECISION AND INITIAL VIDEO MODE
  212.     IVV=11
  213. C SET UP AS THOUGH WE HAD AN @ACINIT.PRM AT STARTUP AND
  214. C ALLOW IT TO GO THRU NORMALLY...
  215.     INQUIRE(FILE='ACINIT.PRM',EXIST=LEXIST)
  216.     IF(.NOT.LEXIST)GOTO 6003
  217.     OPEN(3,FILE='ACINIT.PRM',STATUS='OLD',FORM='FORMATTED')
  218. C    CALL RASSIG(3,'ACINIT.PRM')
  219.     IVV=3
  220.     IOLVL=3
  221.     GOTO 6403
  222. 6003    CONTINUE
  223. C    OPEN(5,FILE='CON:',STATUS='OLD',FORM='FORMATTED')
  224. C OPEN EITHER CONSOLE OR INIT FILE AT FIRST...
  225. 6403    CONTINUE
  226. 6005    FORMAT(80A1)
  227. c    IF(IVV.EQ.11)WRITE(11,6007)
  228. c6007    FORMAT(' Use ANSI.SYS cursor controls or IBM BIOS [A/I]:',\)
  229. C READ INIT FILE OR CONSOLE. ONLY PROMPT IF CONSOLE HOWEVER.
  230. C LEAVE INIT FILE OPEN AS CONSOLE INPUT UNTIL DONE.
  231. c    READ(IVV,6005,END=6006,ERR=6006)CHR
  232. c    IF(CHR.NE.'I'.AND.CHR.NE.'i')GOTO 6008
  233. C For AMIGA always use "BIOS MODE" so we can have special windowing
  234. C code in place of the Fortran I/O. Fortran console I/O will be done
  235. C using LUN 11 in a CON: window, but most normal spreadsheet
  236. C operations will take place in a special window over which we will have
  237. C finer grained control...
  238. C
  239.     CALL SWSET(1)
  240.     MODFLG=1
  241. 6008    CONTINUE
  242. C SETS UP FOR USING ROM BIOS DIRECTLY FOR EVERYTHING...
  243. C COULD THEN USE E.G. NEWKEY TO DO KEYBOARD CMDS.
  244.     GOTO 6002
  245. 6006    CONTINUE
  246. C ERROR ON INPUT HERE... JUST FORGET IT.
  247.     CLOSE(3)
  248.     IOLVL=11
  249. C MAKE SURE LUN 5 HAS A CONSOLE FILE OPEN.
  250.     CLOSE(11)
  251.     OPEN(11,FILE='CON:0/0/100/100/Analy Command',
  252.      1  STATUS='OLD',FORM='FORMATTED')
  253. 6002    CALL UVT100(18,0,0)
  254. C PERFORM SYSTEM DEPENDENT INITIALIZATION for terminal. (none here really)
  255. c may later read + write auxkpd.txt to set up escape seqs.
  256.     CALL TTYINI
  257. C
  258. C SET UP THE SCREEN (ERASE, ETC.)
  259. c erase screen first
  260.     CALL UVT100(1,5,10)
  261.     CALL UVT100(11,2,0)
  262. c position cursor to r5c10
  263.     CALL UVT100(1,5,10)
  264. C ZERO THE VARIABLES TO START OFF WITH.
  265.     DO 2070 KK=1,20
  266.     DO 2070 KKK=1,27
  267. 2070    AVBLS(KK,KKK)=0
  268. C SET UP WORK ARRAY BITMAP
  269.     CALL WRKFIL(1,FORM,2)
  270. c set reverse video title
  271.     CALL UVT100(13,7,0)
  272.     CALL SWRT('AnalytiCalc-68K',15)
  273.     CALL UVT100(1,6,12)
  274.     CALL SWRT('V22-02A',7)
  275.     CALL UVT100(13,0,0)
  276.     CALL UVT100(1,9,3)
  277.     CALL SWRT(' ...The Analyst`s Tool',22)
  278.     CALL UVT100(1,10,5)
  279.     CALL SWRT('Copyright (C) 1987 Glenn & Mary Everhart',40)
  280.     CALL UVT100(1,11,1)
  281. C ALLOW SPACE FOR ASKING FOR MONEY LATER VIA PATCH IF DESIRED.
  282.     CALL SWRT('If you use this program please send $10.00 payment',
  283.      1  50)
  284.     CALL UVT100(1,12,1)
  285.     CALL SWRT('to Glenn Everhart, 25 Sleigh Ride, Glen Mills PA. ',
  286.      1  50)
  287.     CALL UVT100(1,13,1)
  288.     CALL SWRT('19342 to register. May be copied for evaluation   ',
  289.      1  50)
  290.     CALL SWRT(' purposes by recipient for others. ',35)
  291. C NOW GET ON WITH USEFUL WORK.
  292.       PRL ( 2 ) = 1
  293.       PRL ( 3 ) = 0
  294. c set ansi mode...
  295.       CALL UVT100 ( 18 ,0,0)
  296.     KWID=10
  297.     KMAP=1
  298.     RETURN
  299.     END
  300. c -h- acini2.for    Fri Aug 22 12:55:25 1986    
  301. C PORTACALC MAIN PROGRAM
  302. C SPREAD SHEET DRIVER PROGRAM
  303. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  304. C ALL RIGHTS RESERVED
  305. C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
  306. C PARAMETER 18060=60*301
  307. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  308. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  309. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  310. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  311. C FROM THE DISK BASED FILE HERE.
  312.     SUBROUTINE INITA2(KMAP,KWID,ICODE,IKONS)
  313. C
  314.     InTeGer*4 PRL(6)
  315.         CHARACTER*1 NOWRAP ( 2 )
  316.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  317.     INTEGER*4 VNLT
  318.     INTEGER IFCW
  319. C    EXTERNAL LCWRQQ
  320.     DIMENSION FORM(128),FVLD(1,1)
  321. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  322. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  323. C SO INITIALLY IGNORE.
  324. C
  325. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  326. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  327. C ***<<<< RDD COMMON START >>>***
  328.     InTeGer*4 RRWACT,RCLACT
  329. C    COMMON/RCLACT/RRWACT,RCLACT
  330.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  331.      1  IDOL7,IDOL8
  332. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  333. C     1  IDOL7,IDOL8
  334.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  335. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  336.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  337. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  338. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  339. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  340.     InTeGer*4 KLVL
  341. C    COMMON/KLVL/KLVL
  342.     InTeGer*4 IOLVL,IGOLD
  343. C    COMMON/IOLVL/IOLVL
  344. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  345. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  346.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  347.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  348.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  349. C ***<<< RDD COMMON END >>>***
  350. CCC    InTeGer*4 RRWACT,RCLACT
  351. CCC    COMMON/RCLACT/RRWACT,RCLACT
  352. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  353. CCC     1  IDOL7,IDOL8
  354. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  355. CCC     1  IDOL7,IDOL8
  356. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  357. CCC    InTeGer*4 LLCMD,LLDSP
  358. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  359.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  360.     COMMON/D2R/NRDSP,NCDSP
  361. C ***<<< NULETC COMMON START >>>***
  362.     InTeGer*4 ICREF,IRREF
  363. C    COMMON/MIRROR/ICREF,IRREF
  364.     InTeGer*4 MODPUB,LIMODE
  365. C    COMMON/MODPUB/MODPUB,LIMODE
  366.     InTeGer*4 KLKC,KLKR
  367.     REAL*8 AACP,AACQ
  368. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  369.     InTeGer*4 NCEL,NXINI
  370. C    COMMON/NCEL/NCEL,NXINI
  371.     CHARACTER*1 NAMARY(20,301)
  372. C    COMMON/NMNMNM/NAMARY
  373.     InTeGer*4 NULAST,LFVD
  374. C    COMMON/NULXXX/NULAST,LFVD
  375.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  376.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  377. C ***<<< NULETC COMMON END >>>***
  378. CCC    InTeGer*4 ICREF,IRREF
  379. CCC    COMMON/MIRROR/ICREF,IRREF
  380. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  381. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  382. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  383. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  384.     CHARACTER*1 FORM2(4)
  385. C ***<<< XVXTCD COMMON START >>>***
  386.     CHARACTER*1 OARRY(100)
  387.     InTeGer*4 OSWIT,OCNTR
  388. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  389. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  390.     InTeGer*4 IPS1,IPS2,MODFLG
  391. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  392.        InTeGer*4 XTCFG,IPSET,XTNCNT
  393.        CHARACTER*1 XTNCMD(80)
  394. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  395. C VARY FLAG ITERATION COUNT
  396.     INTEGER KALKIT
  397. C    COMMON/VARYIT/KALKIT
  398.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  399.     InTeGer*4 RCMODE,IRCE1,IRCE2
  400. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  401. C     1  IRCE2
  402. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  403. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  404. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  405. C RCFGX ON.
  406. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  407. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  408. C  AND VM INHIBITS. (SETS TO 1).
  409.     INTEGER*4 FH
  410. C FILE HANDLE FOR CONSOLE I/O (RAW)
  411. C    COMMON/CONSFH/FH
  412.     CHARACTER*1 ARGSTR(52,4)
  413. C    COMMON/ARGSTR/ARGSTR
  414.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  415.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  416.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  417.      3  IRCE2,FH,ARGSTR
  418. C ***<<< XVXTCD COMMON END >>>***
  419. CCC    InTeGer*4 OSWIT,OCNTR
  420. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  421. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  422.     InTeGer*4 TYPE(1,1),VLEN(9)
  423. CCC    InTeGer*4 KLVL
  424. CCC    COMMON/KLVL/KLVL
  425. CCC    InTeGer*4 IOLVL
  426. CCC    COMMON/IOLVL/IOLVL
  427. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  428. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  429.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  430.     REAL*8 XXV(1,1)
  431.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  432.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  433. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  434.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  435.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  436.     CHARACTER*12 CDVFMT
  437.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  438.     COMMON/DEFVBX/DVFMT
  439.     CHARACTER*1 NMSH(80)
  440.     CHARACTER*80 NMSH80
  441.     EQUIVALENCE(NMSH80(1:1),NMSH(1))
  442.     COMMON/NMSH/NMSH
  443. CCC    InTeGer*4 IPS1,IPS2,MODFLG
  444. CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
  445. CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
  446. CCC       CHARACTER*1 XTNCMD(80)
  447. CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  448. C VARY FLAG ITERATION COUNT
  449. CCC    INTEGER KALKIT
  450. CCC    COMMON/VARYIT/KALKIT
  451. CCC    InTeGer*4 FORMFG,RCFGX,PZAP
  452. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP
  453. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  454. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  455. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  456. C RCFGX ON.
  457. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  458. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  459. C  AND VM INHIBITS. (SETS TO 1).
  460. C
  461. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  462. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  463. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  464. C DISPLAY ACTUALLY USED FOR SCREEN.
  465.     InTeGer*4 CWIDS(20)
  466. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  467. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  468. C AS 20 NOT 75.
  469.     INTEGER*4 I4TMP
  470.     REAL*8 DVS(20,75)
  471.     COMMON /FVLDC/FVLD
  472. C FOLLOWING SUPPORT VVARY OVERLAY:
  473.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  474.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  475.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  476. C BITMAP
  477. C    CHARACTER*1 IBITMP
  478. C    DIMENSION IBITMP(2258)
  479. C    COMMON/INITD/IBITMP
  480. C    CHARACTER*1 DFMTS(10,20,75)
  481. C 10 CHARACTERS PER ENTRY.
  482.     COMMON/DSPCMN/DVS,CWIDS
  483.     character*35 fwt
  484. C ***<<< KLSTO COMMON START >>>***
  485.     InTeGer*4 DLFG
  486. C    COMMON/DLFG/DLFG
  487.     InTeGer*4 KDRW,KDCL
  488. C    COMMON/DOT/KDRW,KDCL
  489.     InTeGer*4 DTRENA
  490. C    COMMON/DTRCMN/DTRENA
  491.     REAL*8 EP,PV,FV
  492.     DIMENSION EP(20)
  493.     INTEGER*4 KIRR
  494. C    COMMON/ERNPER/EP,PV,FV,KIRR
  495.     InTeGer*4 LASTOP
  496. C    COMMON/ERROR/LASTOP
  497.     CHARACTER*1 FMTDAT(9,76)
  498. C    COMMON/FMTBFR/FMTDAT
  499.     CHARACTER*1 EDNAM(16)
  500. C    COMMON/EDNAM/EDNAM
  501.     InTeGer*4 MFID(2),MFMOD(2)
  502. C    COMMON/FRM/MFID,MFMOD
  503.     InTeGer*4 JMVFG,JMVOLD
  504. C    COMMON/FUBAR/JMVFG,JMVOLD
  505.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  506.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  507. C ***<<< KLSTO COMMON END >>>***
  508. CCC    CHARACTER*1 EDNAM(16)
  509. CCC    COMMON/EDNAM/EDNAM
  510.     CHARACTER*1 EDNINI(4)
  511.     DATA EDNINI/'E','D','I','T'/
  512. C    DATA NOWRAP / "24,0 /
  513. C
  514.     DO 2900 III=1,16
  515. 2900    EDNAM(III)=' '
  516.     DO 2901 III=1,4
  517. 2901    EDNAM(III)=EDNINI(III)
  518.     IF(IKONS.EQ.0)GOTO 3000
  519. 3002    CONTINUE
  520.     CALL UVT100(1,1,1)
  521.     CALL VWRT('Alter Widths or Mapping Y/N:',28)
  522.     ILL=IOLVL
  523. C    IF(ILL.EQ.5)ILL=0
  524.     READ(ILL,3006,END=5600,ERR=5600)FORM
  525.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3000
  526.     CALL VWRT('Enter NEW Global Column Width 1-120:',36)
  527. C ALTER MAPPING DESIRED
  528.     READ(ILL,3004,END=5600,ERR=5600)KWID
  529. 3004    FORMAT(I3)
  530.     IF(KWID.LT.1.OR.KWID.GT.120)KWID=10
  531.     CALL VWRT('Enter length of display in lines (nominally 24):',48)
  532.     READ(ILL,3004,END=5600,ERR=5600)III
  533.     IF(III.LE.4.OR.III.GT.999)III=24
  534. C RESET DISPLAY SIZE IN S COMMAND QUESTIONS AS NEEDED.
  535.     LLDSP=III
  536.     LLCMD=III-1
  537.     CALL VWRT('Change annotate editor from "EDIT" [Y/N]:',41)
  538.     READ(ILL,3006,END=5600,ERR=5600)FORM
  539.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3031
  540.     CALL VWRT('Give desired edit command:',26)
  541.     READ(ILL,3006,END=5600,ERR=5600)EDNAM
  542.     EDNAM(16)=' '
  543. C ENSURE THERE'S A SPACE AT END OF EDITOR NAME
  544. 3031    CONTINUE
  545.     CALL VWRT('Modify Extended Area Remap Y/N: ',31)
  546.     READ(ILL,3006,END=5600,ERR=5600)FORM
  547.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3502
  548.     CALL VWRT('# cols to move over on row overflow:',36)
  549.     READ(ILL,3004,END=5600,ERR=5600)ICREF
  550.     IF(ICREF.GT.60)ICREF=10
  551.     IF(ICREF.LT.0)ICREF=10
  552.     CALL VWRT('# rows to move down on col overflow:',34)
  553.     READ(ILL,3004,END=5600,ERR=5600)IRREF
  554.     IF(IRREF.GT.300)IRREF=50
  555.     IF(IRREF.LT.0)IRREF=50
  556. C FORCE THE RESULTS TO MAKE SENSE. 0 TO 60 ON COLS, 0-300 ON ROWS.
  557. C IF USER BOTHERS TO READ MANUALS THIS WILL BE EXPLAINED.
  558. 3502    CONTINUE
  559.     CALL VWRT('Reset Display to Upper Left of Sheet Y/N:',40)
  560.     READ(ILL,3006,END=5600,ERR=5600)FORM
  561.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')KMAP=0
  562. 3006    FORMAT(80A1,50A1)
  563. 3000    CONTINUE
  564.     RETURN
  565. 5600    CONTINUE
  566.     IOLVL=11
  567.     CLOSE(3)
  568.     CLOSE(11)
  569.     OPEN(11,FILE='CON:0/0/100/100/Analy Command',
  570.      1  STATUS='OLD',FORM='FORMATTED')
  571.     RETURN
  572.     END
  573. c -h- acini3.for    Fri Aug 22 12:55:39 1986    
  574. C PORTACALC MAIN PROGRAM
  575. C SPREAD SHEET DRIVER PROGRAM
  576. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  577. C ALL RIGHTS RESERVED
  578. C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
  579. C PARAMETER 18060=60*301
  580. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  581. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  582. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  583. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  584. C FROM THE DISK BASED FILE HERE.
  585.     SUBROUTINE INITB(KMAP,KWID,ICODE)
  586. C
  587.     InTeGer*4 PRL(6)
  588.         CHARACTER*1 NOWRAP ( 2 )
  589.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  590.     INTEGER*4 VNLT
  591.     INTEGER IFCW
  592. C    EXTERNAL LCWRQQ
  593.     DIMENSION FORM(128),FVLD(1,1)
  594. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  595. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  596. C SO INITIALLY IGNORE.
  597. C
  598. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  599. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  600. C ***<<<< RDD COMMON START >>>***
  601.     InTeGer*4 RRWACT,RCLACT
  602. C    COMMON/RCLACT/RRWACT,RCLACT
  603.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  604.      1  IDOL7,IDOL8
  605. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  606. C     1  IDOL7,IDOL8
  607.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  608. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  609.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  610. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  611. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  612. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  613.     InTeGer*4 KLVL
  614. C    COMMON/KLVL/KLVL
  615.     InTeGer*4 IOLVL,IGOLD
  616. C    COMMON/IOLVL/IOLVL
  617. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  618. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  619.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  620.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  621.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  622. C ***<<< RDD COMMON END >>>***
  623. CCC    InTeGer*4 RRWACT,RCLACT
  624. CCC    COMMON/RCLACT/RRWACT,RCLACT
  625. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  626. CCC     1  IDOL7,IDOL8
  627. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  628. CCC     1  IDOL7,IDOL8
  629. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  630. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  631.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  632.     COMMON/D2R/NRDSP,NCDSP
  633. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  634. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  635. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  636. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  637.     CHARACTER*1 FORM2(4)
  638. d    Integer*4 ill
  639. C ***<<< XVXTCD COMMON START >>>***
  640.     CHARACTER*1 OARRY(100)
  641.     InTeGer*4 OSWIT,OCNTR
  642. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  643. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  644.     InTeGer*4 IPS1,IPS2,MODFLG
  645. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  646.        InTeGer*4 XTCFG,IPSET,XTNCNT
  647.        CHARACTER*1 XTNCMD(80)
  648. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  649. C VARY FLAG ITERATION COUNT
  650.     INTEGER KALKIT
  651. C    COMMON/VARYIT/KALKIT
  652.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  653.     InTeGer*4 RCMODE,IRCE1,IRCE2
  654. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  655. C     1  IRCE2
  656. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  657. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  658. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  659. C RCFGX ON.
  660. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  661. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  662. C  AND VM INHIBITS. (SETS TO 1).
  663.     INTEGER*4 FH
  664. C FILE HANDLE FOR CONSOLE I/O (RAW)
  665. C    COMMON/CONSFH/FH
  666.     CHARACTER*1 ARGSTR(52,4)
  667. C    COMMON/ARGSTR/ARGSTR
  668.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  669.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  670.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  671.      3  IRCE2,FH,ARGSTR
  672. C ***<<< XVXTCD COMMON END >>>***
  673. CCC    InTeGer*4 OSWIT,OCNTR
  674.  
  675. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  676. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  677.     InTeGer*4 TYPE(1,1),VLEN(9)
  678. CCC    InTeGer*4 KLVL
  679. CCC    COMMON/KLVL/KLVL
  680. CCC    InTeGer*4 IOLVL
  681. CCC    COMMON/IOLVL/IOLVL
  682. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  683. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  684.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  685.     REAL*8 XXV(1,1)
  686.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  687.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  688. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  689.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  690.     CHARACTER*12 CDVFMT
  691.     EQUIVALENCE(DEFFMT(1),DVFMT(2))
  692.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  693.     COMMON/DEFVBX/DVFMT
  694.     CHARACTER*1 NMSH(80)
  695.     CHARACTER*80 NMSH80
  696.     EQUIVALENCE(NMSH80(1:1),FORM(1))
  697.     COMMON/NMSH/NMSH
  698. CCC    InTeGer*4 IPS1,IPS2,MODFLG
  699. CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
  700. CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
  701. CCC       CHARACTER*1 XTNCMD(80)
  702. CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  703. C VARY FLAG ITERATION COUNT
  704. CCC    INTEGER KALKIT
  705. CCC    COMMON/VARYIT/KALKIT
  706. CCC    InTeGer*4 FORMFG,RCFGX,PZAP
  707. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP
  708. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  709. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  710. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  711. C RCFGX ON.
  712. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  713. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  714. C  AND VM INHIBITS. (SETS TO 1).
  715. C
  716. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  717. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  718. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  719. C DISPLAY ACTUALLY USED FOR SCREEN.
  720.     InTeGer*4 CWIDS(20)
  721. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  722. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  723. C AS 20 NOT 75.
  724.     INTEGER*4 I4TMP
  725.     REAL*8 DVS(20,75)
  726.     COMMON /FVLDC/FVLD
  727. C FOLLOWING SUPPORT VVARY OVERLAY:
  728.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  729.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  730.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  731. C BITMAP
  732. C    CHARACTER*1 IBITMP
  733. C    DIMENSION IBITMP(2258)
  734. C    COMMON/INITD/IBITMP
  735. C    CHARACTER*1 DFMTS(10,20,75)
  736. C 10 CHARACTERS PER ENTRY.
  737.     COMMON/DSPCMN/DVS,CWIDS
  738.     character*35 fwt
  739. d       Integer*4 ifubar
  740. d    Dimension ifubar(12)
  741. C    DATA NOWRAP / "24,0 /
  742. C
  743.     idol5=20000
  744.     idol6=20000
  745. C INITIALLY SET JRCL TO 301 = NO. OF ROWS TO BE IN WORK FILE
  746.     JRCL=301
  747.     PZAP=0
  748.     XTCFG=0
  749.     IPSET=0
  750. C ZERO BITMAP
  751. C    DO 36 N1=1,2258
  752. C36    IBITMP(N1)=0
  753. c    LINIZZ=0
  754.     CALL UVT100(1,14,1)
  755. d    ill=loc(cdvfmt(1:1))
  756. d    write(*,9211)cdvfmt(1:12),ill
  757. d9211   format(' Default format=',1a12,' Addr=',i12)
  758. d    do 9218 ill=1,12
  759. d    ifubar(ill)=0
  760. d9218    ifubar(ill)=ichar(dvfmt(ill))
  761. d    ill=loc(dvfmt(1))
  762. d    write(*,9217)ifubar,ill
  763. d9217   Format(' Dvfmt=',12i5,' Addr=',i12)
  764.     CALL VWRT('Enter NEW floating format default Y/N:',38)
  765.     ILL=IOLVL
  766. C    IF(ILL.EQ.5)ILL=0
  767.     READ(ILL,3006,END=5600,ERR=5600)FORM
  768.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3589
  769. C ENTER NEW DEFAULT.
  770. 6888    CALL UVT100(1,14,1)
  771.     CALL UVT100(12,2,0)
  772. C LINE NOW ERASED... GET NEW FORMAT
  773.     CALL VWRT('Enter new format. Suggest F10.2>',32)
  774.     READ(ILL,3006,END=5600,ERR=5600)FORM
  775. C NOW HAVE HIS DESIRED FORMAT. COPY INTO THE DEFAULT ARRAY.
  776. C DEFFMT IS THAT.
  777.     DO 3591 N1=1,10
  778.     KKK=ICHAR(FORM(N1))
  779.     KKK=MAX0(32,KKK)
  780. C ASSUME NMSH COMPLETELY INIT'D
  781. 3591    DEFFMT(N1)=Char(KKK)
  782. c    dvfmt(1)='('
  783. c    dvfmt(12)=')'
  784. C CHECK ITS LEGALITY BY TRYING TO USE IT ONCE.
  785.     XX=3.14159
  786. d    write(*,9213)cdvfmt
  787. d9213   format(' Cdvfmt entered=',a12,';')
  788. d    do 9219 ill=1,12
  789. d9219    ifubar(ill)=ichar(dvfmt(ill))
  790. d    write(*,9217)ifubar
  791.     WRITE(NMSH80(1:80),DVFMT,ERR=6888)XX
  792. C    ENCODE(78,DVFMT,NMSH,ERR=6888)XX
  793. C IF IT FAILS, PROGRAM WILL CRASH AND FILE WON'T GET CLOBBERED.
  794. 3589    CONTINUE
  795.     CALL UVT100(1,15,1)
  796.     CALL VWRT('Title for Spreadsheet:',22)
  797.     ILL=IOLVL
  798. C    IF(ILL.EQ.5)ILL=0
  799.     READ(ILL,3006,END=5600,ERR=5600)FORM
  800. 3006    FORMAT(80A1,50A1)
  801.     IF(ICHAR(FORM(1)).LE.32.AND.ICHAR(FORM(2)).LE.32) GOTO 3008
  802. C COPY TITLE UNLESS IT'S OLD
  803.     DO 3007 KKK=1,80
  804. 3007    NMSH(KKK)=FORM(KKK)
  805. C THAT WAY JUST C.R. LEAVES IN OLD TITLE.
  806. 3008    CONTINUE
  807. C ****** IF S OPTION GIVEN THEN ICODE=-2
  808. C THEREFORE, DON'T ASK DISK SIZE ETC, BUT ALLOW RESET OF TITLE
  809. C AND DEFAULT FORMATS.
  810.     IF(ICODE.EQ.-2) GOTO 7831
  811. C ******
  812.     CALL UVT100(1,16,1)
  813.     CALL VWRT('Give Max Rows to be used:',25)
  814.     READ(ILL,7202,END=5600,ERR=5600)KR
  815.     IF(KR.LE.0)KR=301
  816.     CALL UVT100(1,17,1)
  817.     CALL VWRT('Give Max Cols to be used:',25)
  818.     READ(ILL,7202,END=5600,ERR=5600)KC
  819.     IF(KC.LE.0)KC=60
  820. C    KKK=(KR-1)*60+KC
  821. C ALLOW REPLIES IN ANY RANGE AND REFLECT BACK TO PRIME RANGE
  822. C NOTE WE WANT A CELL ADDRESS HERE FOR THE END CELL...
  823.     CALL REFLEC(KR,KC,KKK)
  824.     XKKKK=KR*KC
  825.     XKDF=XKKKK/64.
  826.     XKDN=XKKKK/100.
  827. C COMPUTED ABOVE THE MIN # OF K FOR DISK FILES
  828.     CALL UVT100(1,18,1)
  829.     write(fwt(1:12),2058)xkdn
  830. 2058    format(F9.0)
  831.     CALL SWRT('Min=',4)
  832.     call swrt(fwt(1:12),9)
  833.     write(fwt,2058)xkdf
  834.     call swrt(' K Value file ',14)
  835.     CALL SWRT(fwt(1:12),9)
  836.     CALL SWRT(' K Formula file',15)
  837. c    WRITE(0,2058)XKDN,XKDF
  838. c2058    FORMAT(' Mins=',F9.0' K Value file, ',F9.0,' K Formula file',\)
  839. C KKK IS MAX INDEX TO BE USED HERE.
  840.     CALL UVT100(1,21,1)
  841.     CALL VWRT('Give Value File size, K:',24)
  842.     READ(ILL,7202,END=5600,ERR=5600)IPGMAX
  843. 7202    FORMAT(I6)
  844.     IPGMOD=KKK
  845.     IF(IPGMAX.LT.0)IPGMOD=0
  846.     IPGMAX=IABS(IPGMAX)
  847.     IF(IPGMAX.GT.2512)IPGMAX=1
  848.     CALL UVT100(1,22,1)
  849.     CALL VWRT('Give Formula File size, K:',26)
  850.     READ(ILL,7202,END=5600,ERR=5600)LPGMXF
  851.     LPGMOD=KKK
  852.     IF(LPGMXF.LT.0)LPGMOD=0
  853.     LPGMXF=IABS(LPGMXF)
  854. C IF NUMBERS ARE ENTERED NEGATIVE, SET MODE TO "SLOW, FILE-SPACE
  855. C CONSERVING" PACKING, SCATTERING PAGES ACROSS FILE.
  856.     IF(LPGMXF.GT.4096)LPGMXF=(IPGMAX*3)/2
  857. C NULL TERMINATE ALL FORMAT STRINGS.
  858. C SET MAX WIDTH FOR PRINT TO DIMENSION OF THE BUFFER. NOTE THIS IS THE
  859. C USUAL HARDWARE MAXIMUM SO WE DON'T WORRY TOO MUCH ABOUT IT. NOTE
  860. C BILL TABOR'S PROGRAM TO PRINT PASTE-ABLE VERSIONS OF THE SHEET FROM
  861. C SAVE FILES EXISTS, SO WE NEEDN'T WORRY TOO MUCH EITHER ABOUT USING
  862. C DISPLAY FOR DOUBLE DUTY.
  863.     MXL=132
  864. C INITIALIZE WORK STORAGE FOR FORMULAS AND VARIABLES
  865.     CALL WSSET
  866. 7831    CONTINUE
  867. C SET DEFAULT WIDTHS OF COLUMNS TO 10. MAY BE ALTERED BELOW FOR DIFFERENT
  868. C DEFAULT IF DESIRED.
  869.     DO 16 N1=1,20
  870.     CWIDS(N1)=KWID
  871. 16    CONTINUE
  872. C
  873. C NOW SET UP NRDSP, NCDSP
  874.     IF(KMAP.EQ.0)GOTO 3009
  875. C SET UP MAPPING NOW FOR INITIALLY UPPER LEFT CORNER OF PHYS SHEET IN DISPLAY SHT.
  876.     DO 5 N1=1,20
  877.     DO 5 N2=1,75
  878. C INITIALLY WE DISPLAY THE UPPER LEFT PART OF THE SYSTEM.
  879. C ESTABLISH ASSOCIATION INITIALLY THEREFORE OF DISPLAY TO UPPER
  880. C LEFT OF PHYSICAL SHEET.
  881.     NRDSP(N1,N2)=N1
  882.     NCDSP(N1,N2)=N2+1
  883.     DVS(N1,N2)=.00000031
  884. 5    CONTINUE
  885. C FOR S OPTION USE SECRET -4 CODE TO RESET SHEET. STILL NEEDS WORK
  886. C IN PORTACALC PC.
  887.     IF(ICODE.EQ.-4)CALL WRKFIL(1,FORM,2)
  888. 3009    IF(ICODE.EQ.-4)GOTO 1
  889. C43    CALL UVT100(1,21,1)
  890.     KZPPD=0
  891.     CMDLIN(1)=0
  892.     IOLDFL=0
  893. C3017    FORMAT(Q,80A1,80A1)
  894.     MXL=1
  895.     CMDLIN(MXL+1)=0
  896. 3572    FORMAT(I6)
  897.     CALL UVT100(13,0,0)
  898. C  SET UP RANDOM FILE AS NEEDED FOR SHEET
  899. C EACH RECORD HAS:
  900. C CHARS 1-110    FORMULAS
  901. C CHARS 120-128    DISPLAY FORMAT (INITIALLY F9.2)
  902. C CHAR 119    VALID FLAG (ALLOWS HANDLING READS.)
  903. C    values: -3, -2: Numeric-only text (or special chars)
  904. C         -1    : Alphanumeric text
  905. C          0    : Uninitialized
  906. C          1    : Alphanumeric formula
  907. C         +2    : Number or pure numeric formula with value calculated
  908. C         +3    : Number or pure numeric formula, value not yet computed
  909. C CHAR 118    MAGIC NUMBER 15 (CHECKS ALL WELL)
  910. C READ A RECORD, IF ERROR, CREATE EMPTY FILE.
  911. C    IF(IOLDFL.EQ.0)GOTO 1
  912. CC IF IOLDFL NONZERO IT MEANS USER CLAIMS THERE EXISTS A FILE. IF 0 IT'S NEW.
  913. CC HERE IT'S OLD SO LET'S BE SURE IT REALLY IS OK.
  914. 1    CONTINUE
  915. C HIT EOF OR ERROR. MUST BE A NEW FILE. THEREFORE ZERO IT TO OUR NEEDS.
  916. C AT THIS POINT WE ARE CREATING A NEW FILE AND NEED TO ZERO IT.
  917. C
  918.     DO 3 N=1,128
  919.     FORM(N)=0
  920. 3    CONTINUE
  921.     DO 3592 N=1,9
  922. C SET UP DEFAULT FORMAT
  923. 3592    FORM(119+N)=DEFFMT(N)
  924.     FORM(118)=CHAR(15)
  925.     FORM(1)='0'
  926.     FORM(2)='.'
  927. C CREATE NULL FILE INITIALLY BY RESETTING ALL.
  928.     JRRCL=60*JRCL
  929.     KZPPD=1
  930. C
  931. 2    CONTINUE
  932. C COMMON POINT WITH FILE PREPARED.
  933.     PCOL=2
  934.     PROW=1
  935.     DCOL=1
  936.     DROW=1
  937.     RETURN
  938. 5600    CONTINUE
  939. C ERROR ON READ FROM IOLVL HANDLED HERE.
  940. C    REWIND 5
  941.     CLOSE(11)
  942.     OPEN(11,FILE='CON:0/150/500/49/Analy Command',
  943.      1  STATUS='OLD',FORM='FORMATTED')
  944.     CLOSE(3)
  945.     IOLVL=11
  946.     RETURN
  947.     END
  948. c -h- block.for    Fri Aug 22 12:58:14 1986    
  949.     SUBROUTINE BLOCK
  950. C    BLOCK DATA
  951. C COPYRIGHT (C) 1983 GLENN EVERHART
  952. C ALL RIGHTS RESERVED
  953. C 18060 = 60*301
  954. C 18033=18060-27
  955. C 60=MAX REAL ROWS
  956. C 301=MAX REAL COLS
  957. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  958. C VBLS AND TYPE DIMENSIONED 60,301
  959. C   ++++++++++++++++++++++++++++++++++++++++++++++++++
  960. C   +                                                +
  961. C   +            CALC    VERSION  X01-06             +
  962. C   +                                                +
  963. C   ++++++++++++++++++++++++++++++++++++++++++++++++++
  964. C
  965. C
  966. C *******************************************************
  967. C *                                                     *
  968. C *            BLOCK  DATA  MODULE                      *
  969. C *                                                     *
  970. C *******************************************************
  971. C
  972. C
  973. C COMMON AREAS ARE INITIALIZED BY THIS MODULE.
  974. C FAKEUP FOR MICROSOFT WHICH HAS NO BLOCK DATA.
  975. C DO IT ALL VIA LOOPS...
  976. C
  977. C
  978. C MODIFIED 18-MAY-1981 P.B. SET % TO VERSION 6
  979. C
  980. C
  981. C
  982. C   VARIABLE      USE
  983. C
  984. C  ALPHA(27)    HOLDS LEGAL VARIABLE NAMES: ALPHABETIC CHARACTERS
  985. C               OR THE CHARACTER %.
  986. C  BASED     HOLDS DEFAULT BASE.
  987. C  BLANK        ' '
  988. C  COMMA        ','
  989. C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
  990. C               SECOND SUBSCRIPT IS
  991. C                     1 FOR DECIMAL
  992. C                     2 FOR OCTAL
  993. C                     3 FOR HEXADECIMAL
  994. C  DTBL1(9,9,8) CONTROLS THE DECISION PROCESS WHEN EVALUATING A
  995. C               BINARY OPERATION. SEE BELOW FOR DETAILS.
  996. C  EQ           '='
  997. C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
  998. C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
  999. C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
  1000. C               USED TO CONTROL ITERATION.
  1001. C  LINE(80)     COMMAND INPUT LINE
  1002. C  LPAR         '('
  1003. C  RPAR         ')'
  1004. C  ST1LIM       HOLDS THE SIZE OF STACK 1 (ALWAYS CONSTANT)
  1005. C  ST2LIM       HOLDS THE SIZE OF STACK 2 (ALWAYS CONSTANT)
  1006. C  ST1PT        POINTS TO THE TOP OF STACK 1 (CHANGES AS STACK IS USED)
  1007. C  ST2PT        POINTS TO THE TOP OF STACK 2 (CHANGES AS STACK IS USED)
  1008. C  ST1TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 1
  1009. C  ST2TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 2
  1010. C  STACK1(20,40)   UTILITY STACKS USED WHEN EVALUATING EXPRESSIONS. THE FIRST
  1011. C  STACK2(20,40)   SUBSCRIPT CONTROLS INDEXING ACROSS THE BYTES OF A SINGLE
  1012. C                   VARIABLE. THE SECOND SUBSCRIPT CONTROLS STACK ELEMENTS.
  1013. C  TYPE(27)         HOLDS THE DATA TYPES FOR EACH OF THE 27 VARIABLES. SEE
  1014. C                   CODES.FTN FOR THE POSSIBLE VALUES.
  1015. C  VIEWSW           VIEW SWITCH
  1016. C                    0 = OUTPUT ERROR MESSAGES
  1017. C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
  1018. C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
  1019. C                        EVALUATED.
  1020. C                    3 = OUTPUT EVERYTHING
  1021. C  VLEN(9)      INDEXED BY DATA TYPE. GIVES THE NUMBER OF BYTES USED
  1022. C               BY THAT DATA TYPE.
  1023. C  AVBLS(20,27)      HOLDS THE VALUES OF THE 27 LEGAL VARIABLES.(ACCUMULATORS)
  1024. C  VBLS(8,60,301)    HOLDS VALUES OF ALL VARIABLES
  1025. C
  1026. C
  1027. C
  1028. C    CONSTANTS ARE STORED IN VBLS ACCORDING TO THEIR TYPE:
  1029. C
  1030. C
  1031. C
  1032. C <----------- MULTIPLE PRECISION (M10, M8, M16) ------------------------->
  1033. C !                        <------------- DECIMAL AND REAL --------------->
  1034. C !                        !                      <-- INTEGER HEX OCTAL -->
  1035. C !                                               !             ---> ASCII <---
  1036. C !                        !                      !                        !
  1037. C
  1038. C -------------     -------------------------------------------------------
  1039. C !     !     !     !     !     !     !     !     !     !     !     !     !
  1040. C ! 20  !  19 ! ... !  9  !  8  !  7  !  6  !  5  !  4  !  3  !  2  !  1  !
  1041. C !     !     !     !     !     !     !     !     !     !     !     !     !
  1042. C -------------     -------------------------------------------------------
  1043. C
  1044. C
  1045. C NOTE: BYTE 20 HOLDS THE SIGN FOR MULTIPLE PRECISION NUMBERS.
  1046. C       0 = POSITIVE, 1 = NEGATIVE
  1047. C
  1048. C
  1049. C
  1050. C
  1051. C
  1052. C    BLOCK DATA
  1053.     InTeGer*4 LEVEL,NONBLK,LEND
  1054.     InTeGer*4 LASTOP
  1055.     InTeGer*4 ST1TYP(40),ST2TYP(40)
  1056.     InTeGer*4 TYPE(1,1)
  1057.     InTeGer*4 VIEWSW,BASED,VLEN(9),BVLEN(9)
  1058.     InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
  1059.     InTeGer*4 ITCNTV(6)
  1060. C
  1061.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ,LINE(80)
  1062.     CHARACTER*1 BOMMA,BBLANK,BRPAR,BLPAR,BEQ
  1063.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  1064.     CHARACTER*1 AVBLS(20,27),BLPHA(27)
  1065.     CHARACTER*1 VBLS(8,1,1)
  1066. C ***<<< XVXTCD COMMON START >>>***
  1067.     CHARACTER*1 OARRY(100)
  1068. d    integer*4 ill
  1069.     InTeGer*4 OSWIT,OCNTR
  1070. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  1071. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  1072.     InTeGer*4 IC1POS,IC2POS,MODFLG
  1073. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  1074.        InTeGer*4 XTCFG,IPSET,XTNCNT
  1075.        CHARACTER*1 XTNCMD(80)
  1076. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  1077. C VARY FLAG ITERATION COUNT
  1078.     INTEGER KALKIT
  1079. C    COMMON/VARYIT/KALKIT
  1080.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  1081.     InTeGer*4 RCMODE,IRCE1,IRCE2
  1082. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1083. C     1  IRCE2
  1084. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  1085. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  1086. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  1087. C RCFGX ON.
  1088. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  1089. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  1090. C  AND VM INHIBITS. (SETS TO 1).
  1091.     INTEGER*4 FH
  1092. C FILE HANDLE FOR CONSOLE I/O (RAW)
  1093. C    COMMON/CONSFH/FH
  1094.     CHARACTER*1 ARGSTR(52,4)
  1095. C    COMMON/ARGSTR/ARGSTR
  1096.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
  1097.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  1098.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1099.      3  IRCE2,FH,ARGSTR
  1100. C ***<<< XVXTCD COMMON END >>>***
  1101. CCC    InTeGer*4 IC1POS,IC2POS
  1102. CCC    COMMON/ICPOS/IC1POS,IC2POS
  1103.     CHARACTER*1 DTBL1(9,9,8)
  1104. CC BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  1105. C MOVED TABLE TO WRKFIL WHERE IT IS OVERLAIN BY A BUFFER DURING OPERATION
  1106. C AND JUST INITIALIZES DTBL1 AT STARTUP. THIS SHOULD ESSENTIALLY REMOVE DATA
  1107. C SPACE PENALTY FOR THIS HUGE ARRAY. NOTE IT'D BE SMALLER IF THERE WEREN'T
  1108. C SO MANY SUPPORTED DATA TYPES IN CALC.
  1109. C    InTeGer*4 BTBL(9,9,8)
  1110. C    InTeGer*4 BTBL1(9,9)
  1111. C    InTeGer*4 BTBL2(9,9),BTBL3(9,9),BTBL4(9,9),BTBL5(9,9)
  1112. C    InTeGer*4 BTBL6(9,9),BTBL7(9,9),BTBL8(9,9)
  1113. C    EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  1114. C    EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  1115. C    EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  1116. C    EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  1117.     CHARACTER*1 DIGITS(16,3),BIGITS(16,3)
  1118. C
  1119. C OARRY WILL BE USED TO HOLD OUTPUT VARIABLE IF OSWIT IS NONZERO
  1120. CCC    InTeGer*4 OSWIT
  1121. C OCNTR MAY HOLD BYTES VALID IN OARRY (UP TO 100, NO MORE...)
  1122. CCC    InTeGer*4 OCNTR
  1123. CCC    CHARACTER*1 OARRY(100)
  1124. C
  1125. C ILINE IS PROGRAMMABLE LINE INPUT (I.E., NOT FROM CONSOLE)
  1126.     CHARACTER*1 ILINE(106)
  1127.     InTeGer*4 ILNFG
  1128.     InTeGer*4 ILNCT
  1129.     COMMON /ILN/ILNFG,ILNCT,ILINE
  1130. C ILINE IS PRESENT IF ILNFG <> 0 AND ILNCT HAS # BYTES IN IT.
  1131. CCC    COMMON /OAR/OSWIT,OCNTR,OARRY
  1132.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  1133.     COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  1134.     COMMON /STACK/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  1135.      ;         ST1LIM,ST2LIM
  1136.     COMMON /V/ TYPE,AVBLS,VBLS,VLEN
  1137.     COMMON /DECIDE/ DTBL1
  1138.     COMMON /DIGV/ DIGITS
  1139. C ***<<< KLSTO COMMON START >>>***
  1140.     InTeGer*4 DLFG
  1141. C    COMMON/DLFG/DLFG
  1142.     InTeGer*4 KDRW,KDCL
  1143. C    COMMON/DOT/KDRW,KDCL
  1144.     InTeGer*4 DTRENA
  1145. C    COMMON/DTRCMN/DTRENA
  1146.     REAL*8 EP,PV,FV
  1147.     DIMENSION EP(20)
  1148.     INTEGER*4 KIRR
  1149. C    COMMON/ERNPER/EP,PV,FV,KIRR
  1150. c    InTeGer*4 LASTOP
  1151. C    COMMON/ERROR/LASTOP
  1152.     CHARACTER*1 FMTDAT(9,76)
  1153. C    COMMON/FMTBFR/FMTDAT
  1154.     CHARACTER*1 EDNAM(16)
  1155. C    COMMON/EDNAM/EDNAM
  1156.     InTeGer*4 MFID(2),MFMOD(2)
  1157. C    COMMON/FRM/MFID,MFMOD
  1158.     InTeGer*4 JMVFG,JMVOLD
  1159. C    COMMON/FUBAR/JMVFG,JMVOLD
  1160.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  1161.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  1162. C ***<<< KLSTO COMMON END >>>***
  1163. CCC    COMMON /ERROR/ LASTOP
  1164.     COMMON/ITERA/ ITCNTV
  1165.     CHARACTER*1 DVFMT(12),BVFMT(12)
  1166.     COMMON/DEFVBX/DVFMT
  1167. C SUPPORT VVARY OVERLAY WITH INITIAL VARY DATA:
  1168.     REAL*8 QAC(26),QDERIV(8),QDEL(8),QOLDVV
  1169.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  1170.     COMMON/VRYDAT/QAC,QDERIV,QDEL,QCAC,QCENT,QOLDVV,ACV
  1171. C INITIAL DEFAULT FORMAT FOR NUMERICS
  1172.     DATA BVFMT/'(','F','9','.','2',' ',
  1173.      1  ' ',' ',' ',' ',' ',')'/
  1174. C
  1175. C    DATA BIEWSW/2/
  1176. C    DATA ITCNTV/6*0/
  1177.     DATA BLPHA/'A','B','C','D','E','F','G','H','I','J','K','L','M',
  1178.      ;       'N','O','P','Q','R','S','T','U','V','W','X','Y','Z','%'/
  1179.     DATA BIGITS/'1','2','3','4','5','6','7','8','9',
  1180.      1  '0','0','0','0','0','0','0',
  1181.      ;       '1','2','3','4','5','6','7',
  1182.      1  '0','0','0','0','0','0','0','0','0',
  1183.      ;  '1','2','3','4','5','6','7','8','9','A','B','C','D','E','F','0'/
  1184.     DATA BOMMA/','/,BBLANK/' '/,BRPAR/')'/,BLPAR/'('/,BEQ/'='/
  1185. C
  1186. C
  1187. C DEFAULT BASE IS 10
  1188. C    DATA BASED/10/
  1189. C
  1190. C
  1191. C STACKS ARE CURRENTLY SET AT 40 ELEMENTS DEEP
  1192. C    DATA ST1LIM/40/, ST2LIM/40/
  1193. C
  1194. C
  1195. C
  1196. C    DEFAULT TYPES
  1197. C    A,B,C,D,E,F,G,H  =  DECIMAL
  1198. C    I,J,K,L,M,N      =  INTEGER (BASE10)
  1199. C    O,P,Q,R,S,T,U,V,W,X,Y,Z  =  DECIMAL
  1200. C
  1201. C  % AS INTEGER TO HOLD CALC VERSION NUMBER
  1202. C
  1203. C    DATA TYPE/8*2,6*4,12*2,4,1*2/
  1204. c modify type array so ac's i-n are reals
  1205. C    DATA TYPE/8*2,6*2,12*2,2,1*2/
  1206. C
  1207. C
  1208. C GIVE VERSION # BY VALUE IN %
  1209. C
  1210. c don't bother with this; by the time user gets into calc,
  1211. c % already is clobbered most times, so no need for it.
  1212. c    DATA AVBLS(1,27)/6/
  1213. c    DATA AVBLS(2,27)/0/,AVBLS(3,27)/0/,AVBLS(4,27)/0/
  1214. C
  1215. C
  1216. C
  1217. C
  1218. C SPECIFY THE LENGTH USED BY EACH DATA TYPE
  1219.     DATA BVLEN/1,8,4,4,8,8,8,4,8/
  1220. C
  1221. C NOTE ALL LENGTHS 8 OR LESS SINCE MULTIPLE PRECISION THINGS SNIPPED OUT
  1222. C
  1223. C  DECISION TABLE FOR PERFORMING BINARY OPERATIONS
  1224. C
  1225. C  DTBL1(OPERAND2,OPERAND1,INDEX)
  1226. C
  1227. C  WHERE:                    OPERATOR:
  1228. C  INDEX=1    MODIFY CODE FOR OPERAND 1    */+-
  1229. C     2    MODIFY CODE FOR OPERAND 2    */+-
  1230. C     3    FUNCTION VALUE TYPE        */+-
  1231. C     4    OPERATOR CLASS            */+-
  1232. C
  1233. C     5    MODIFY CODE FOR OPERAND 1    **
  1234. C     6    MODIFY CODE FOR OPERAND 2    **
  1235. C     7    FUNCTION VALUE TYPE        **
  1236. C     8    OPERATOR CLASS            **
  1237. C
  1238. C
  1239. C  WHERE TYPE CODES (MODIFY CODES) ARE:
  1240. C    0    NO CHANGE
  1241. C    1    CONVERT TO ASCII
  1242. C    2    CONVERT TO DECIMAL
  1243. C    3    CONVERT TO HEXADECIMAL
  1244. C    4    CONVERT TO INTEGER
  1245. C    5    CONVERT TO M10
  1246. C    6    CONVERT TO M8
  1247. C    7    CONVERT TO M16
  1248. C    8    CONVERT TO OCTAL
  1249. C    9    CONVERT TO REAL
  1250. C
  1251. C  FOR */+- FUNCTION VALUE TYPES AND OPERATOR CLASS ARE PRESENTLY
  1252. C  IDENTICAL
  1253. C
  1254. C  FOR **  OPERATOR CLASSES FOLLOW:
  1255. C
  1256. C     CODE    OPERATOR CLASS
  1257. C    1    REAL**REAL
  1258. C    2    REAL**INTEGER
  1259. C    3    INTEGER**REAL
  1260. C    4    INTEGER**REAL
  1261. C    5    M8**INTEGER
  1262. C    6    M10**INTEGER
  1263. C    7    M16**INTEGER
  1264. C
  1265. C
  1266. C
  1267. C    DATA BTBL1 /4,2,3,4,5,6,7,8,9,
  1268. C     1  9*0,0,2,0,0,3*7,0,9,0,2,0,0,5,5,7,0,9,0,2,7,0,0,0,7,0,9,
  1269. C     2  0,2,7,5,5,0,7,0,9,0,2,6*0,9,0,2,3,0,5,6,7,0,9,0,2,7*0/
  1270. C    DATA BTBL2/
  1271. C     3  4,8*0,2,0,6*2,0,3,3*0,7,7,3*0,4,4*0,5,3*0,5,0,7,5,0,5,0,5,0,
  1272. C     4  6,0,7,5,3*0,6,0,7,2,4*7,0,7,0,8,8*0,9,0,6*9,0/
  1273. C    DATA BTBL3/4,2,3,4,5,6,7,8,9,
  1274. C     5  9*2,3,2,3,3,3*7,3,9,4,2,3,4,5,5,7,4,9,5,2,7,3*5,7,5,9,
  1275. C     6  6,2,7,5,5,6,7,6,9,7,2,6*7,9,8,2,3,4,5,6,7,8,9,9,2,7*9/
  1276. C    DATA BTBL4/
  1277. C     7  4,2,3,4,5,6,7,8,9,9*2,3,2,3,3,3*7,3,9,4,2,3,4,5,5,7,4,9,
  1278. C     8  5,2,7,5,5,5,7,5,9,6,2,7,5,5,6,7,6,9,7,2,6*7,9,8,2,3,4,5,6,7,8,9,
  1279. C     9  9,2,7*9/
  1280. C    DATA BTBL5/4,2,3,6*4,9*0,9*0,9*0,0,9,6*0,9,0,9,6*0,9,0,9,6*0,9,
  1281. C     1  9*0,9*0/
  1282. C    DATA BTBL6/4,3*0,3*9,4,0,4,3*0,3*9,0,0,4,3*0,3*9,2*0,4,3*0,3*9,
  1283. C     2  2*0,4,3*0,3*4,2*0,4,3*0,3*4,2*0,4,3*0,3*4,2*0,4,3*0,3*9,2*0,
  1284. C     3  4,3*0,3*9,2*0/
  1285. C        DATA BTBL7/4,2,3,6*4,9*2,9*3,9*4,5,9,6*5,9,6,9,6,6,5,6,7,6,9,
  1286. C     4  7,9,6*7,9,9*8,9*9/
  1287. C    DATA BTBL8/4,1,4,4,3,3,3,4,3,2,1,2,2,3*1,2,1,4,3,4,4,3*3,
  1288. C     5  4,3,4,3,4,4,3*3,4,3,6,1,6*6,1,5,1,6*5,1,7,1,6*7,1,4,3,4,4,3*3,
  1289. C     6  4,3,2,1,2,2,3*1,2,1/
  1290. C
  1291. C HERE COPY LOCAL DATA INTO THE COMMONS.
  1292. C SINCE MOST ARRAYS AND THINGS ARE SMALL, WE JUST DO IT WITH REGULAR FORTRAN.
  1293. C THE BTBL ARRAY IS HANDLED IN WRKFIL WHERE THERE'S A BIG ENOUGH ARRAY FOR
  1294. C SCRATCH SPACE TO HOLD THE INITIAL DATA; WRKFIL IS CALLED BY WSSET WITH
  1295. C "SECRET CODE" TO INIT DTBL1 FROM THE ARRAY AND DOES SO ONCE ONLY.
  1296.     VIEWSW=0
  1297.     LEVEL=1
  1298.     LASTOP=0
  1299.     BASED=10
  1300.     COMMA=BOMMA
  1301.     BLANK=BBLANK
  1302.     RPAR=BRPAR
  1303.     LPAR=BLPAR
  1304.     EQ=BEQ
  1305.     DO 1 N=1,6
  1306.     ITCNTV(N)=0
  1307. 1    CONTINUE
  1308.     DO 2 N=1,27
  1309.     DO 12 NN=1,20
  1310. 12    AVBLS(NN,N)=0
  1311. 2    ALPHA(N)=BLPHA(N)
  1312.     ST1LIM=40
  1313.     ST2LIM=40
  1314. C THIS IS DONE IN WRKFIL SINCE THERE'S A BIG LOCAL ARRAY THERE
  1315. C WE CAN KEEP EQUIVALENCED TO THIS ONE...
  1316. C    DO 3 N2=1,9
  1317. C    DO 3 N1=1,9
  1318. C    DTBL1(N1,N2,2)=BTBL2(N1,N2)
  1319. C    DTBL1(N1,N2,3)=BTBL3(N1,N2)
  1320. C    DTBL1(N1,N2,4)=BTBL4(N1,N2)
  1321. C    DTBL1(N1,N2,5)=BTBL5(N1,N2)
  1322. C    DTBL1(N1,N2,6)=BTBL6(N1,N2)
  1323. C    DTBL1(N1,N2,7)=BTBL7(N1,N2)
  1324. C    DTBL1(N1,N2,8)=BTBL8(N1,N2)
  1325. C3    DTBL1(N1,N2,1)=BTBL1(N1,N2)
  1326.     DO 4 N=1,9
  1327.     VLEN(N)=BVLEN(N)
  1328. 4    CONTINUE
  1329.     DO 5 N2=1,3
  1330.     DO 5 N1=1,16
  1331.     DIGITS(N1,N2)=BIGITS(N1,N2)
  1332. 5    CONTINUE
  1333. C SET UP DEFAULT DISPLAY FORMAT (INCLUDES "(" AND ")" CHARS WHICH
  1334. C ***MUST*** BE THERE FOR MAIN PGM TO WORK).
  1335.     DO 17 N=1,12
  1336.     DVFMT(N)=BVFMT(N)
  1337. 17    Continue
  1338. d    ill=loc(bvfmt(1))
  1339. d    write(*,9210) (bvfmt(n),n=1,12),ill
  1340. d    ill=loc(dvfmt(1))
  1341. d    write(*,9210) (dvfmt(n),n=1,12),ill
  1342. d9210   Format(' Bvfmt at init=',12A1,': addr=',i12)
  1343.     DO 15 N=1,26
  1344.     QAC(N)=0.
  1345. 15    CONTINUE
  1346.     DO 18 N=1,8
  1347.     QDERIV(N)=1.
  1348.     ACV(N)=0
  1349.     QDEL(N)=0.
  1350.     QCENT(N)=0
  1351. 18    CONTINUE
  1352.     QOLDVV=1.
  1353.     QCAC=1
  1354.     OSWIT=0
  1355.     OCNTR=0
  1356.     ILNFG=0
  1357.     ILNCT=0
  1358.     IC1POS=0
  1359.     IC2POS=0
  1360.     RETURN
  1361.     END
  1362. c -h- dtrcmd.for    Fri Aug 22 13:04:33 1986    
  1363. C DATATRIEVE INTERFACE FUNCTIONS
  1364. C NON-DATATRIEVE PARTS, FOR MSDOS VERSION
  1365. C
  1366. C THIS IS THE NON-DTR VERSION with dummy entry points for
  1367. C the DTR functions BUT supplying the new non-DTR functions
  1368. c completely.
  1369.     SUBROUTINE DTRCMD(LINE)
  1370.     CHARACTER*1 LINE(80)
  1371.     CHARACTER*62 LINEC
  1372. C    EQUIVALENCE(LINEC(1:1),LINE(1))
  1373. C    INCLUDE 'VKLUGPRM.FTN'
  1374. C COPYRIGHT (C) 1983 GLENN EVERHART
  1375.     INTEGER RETCD
  1376. C
  1377. C DEFINE FILE AREAS FOR MAPPING FILES...
  1378. C ONE INPUT FILE, TO BE ACCESSED AS A RANDOM ACCESS FILE OF 128 BYTE
  1379. C RECORDS OF DATA IF RANDOM, OR AS A FORMULA FILE IF SEQUENTIAL, AND
  1380. C ONE OUTPUT FILE TO BE WRITTEN THE SAME WAY. INPUT FILE CAN BE
  1381. C INPUT - ONLY OR READ/WRITE.
  1382. C
  1383. C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL)
  1384. C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED.
  1385. C
  1386. C MFIOPN =    0    IF NOT OPEN
  1387. C        1    IF OPEN FOR READ ONLY, SEQUENTIAL
  1388. C        2    IF OPEN READ ONLY, RANDOM
  1389. C        3    IF OPEN READ/WRITE, RANDOM.
  1390. C
  1391. C MFOOPN =    0    IF NOT OPEN
  1392. C        1    IF OPEN WRITE SEQUENTIAL
  1393. C        2    IF OPEN WRITE RANDOM
  1394. C
  1395. C OTHER OPTIONS DON'T MAKE SENSE.
  1396. C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE
  1397. C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE
  1398. C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS
  1399. C MFILUN,MFOLUN ARE LOGICAL UNITS.
  1400.     InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
  1401.     InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
  1402.  
  1403.     InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
  1404.     COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
  1405.      1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
  1406. C
  1407. C
  1408.     CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
  1409.     InTeGer*4 TYPE(1,1),VLEN(9)
  1410.     REAL*8 XAC,XVBLS(1,1)
  1411.     REAL*8 TAC,UAC,VAC,WAC,YAC
  1412.     REAL*8 TMP
  1413.     INTEGER*4 JVBLS(2,1,1)
  1414.     EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
  1415.     EQUIVALENCE(XAC,AVBLS(1,27))
  1416.     EQUIVALENCE(TAC,AVBLS(1,20))
  1417.     EQUIVALENCE(UAC,AVBLS(1,21))
  1418.     EQUIVALENCE(VAC,AVBLS(1,22))
  1419.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  1420.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  1421.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  1422. CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
  1423. CCC    CHARACTER*1 XTNCMD(80)
  1424. C ***<<<< RDD COMMON START >>>***
  1425.     InTeGer*4 RRWACT,RCLACT
  1426. C    COMMON/RCLACT/RRWACT,RCLACT
  1427.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  1428.      1  IDOL7,IDOL8
  1429. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  1430. C     1  IDOL7,IDOL8
  1431.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  1432. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  1433.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1434. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1435. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  1436. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  1437.     InTeGer*4 KLVL
  1438. C    COMMON/KLVL/KLVL
  1439.     InTeGer*4 IOLVL,IGOLD
  1440. C    COMMON/IOLVL/IOLVL
  1441. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  1442. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  1443.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  1444.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  1445.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  1446. C ***<<< RDD COMMON END >>>***
  1447. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  1448. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  1449. CCC    InTeGer*4 RRWACT,RCLACT
  1450. CCC    COMMON/RCLACT/RRWACT,RCLACT
  1451. C ***<<< XVXTCD COMMON START >>>***
  1452.     CHARACTER*1 OARRY(100)
  1453.     InTeGer*4 OSWIT,OCNTR
  1454. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  1455. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  1456.     InTeGer*4 IPS1,IPS2,MODFLG
  1457. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  1458.        InTeGer*4 XTCFG,IPSET,XTNCNT
  1459.        CHARACTER*1 XTNCMD(80)
  1460. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  1461. C VARY FLAG ITERATION COUNT
  1462.     INTEGER KALKIT
  1463. C    COMMON/VARYIT/KALKIT
  1464.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  1465.     InTeGer*4 RCMODE,IRCE1,IRCE2
  1466. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1467. C     1  IRCE2
  1468. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  1469. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  1470. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  1471. C RCFGX ON.
  1472. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  1473. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  1474. C  AND VM INHIBITS. (SETS TO 1).
  1475.     INTEGER*4 FH
  1476. C FILE HANDLE FOR CONSOLE I/O (RAW)
  1477. C    COMMON/CONSFH/FH
  1478.     CHARACTER*1 ARGSTR(52,4)
  1479. C    COMMON/ARGSTR/ARGSTR
  1480.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  1481.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  1482.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1483.      3  IRCE2,FH,ARGSTR
  1484. C ***<<< XVXTCD COMMON END >>>***
  1485. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  1486. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  1487. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  1488. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  1489. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  1490. C (IMPLEMENT FOR VAX ONLY)
  1491. CCC    INTEGER KALKIT
  1492. CCC    COMMON/VARYIT/KALKIT
  1493. C ARGUMENTS COME IN IN ARGUMENTS IN LINE
  1494. C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
  1495. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  1496. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  1497.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  1498.     COMMON/D2R/NRDSP,NCDSP
  1499. C ***<<< KLSTO COMMON START >>>***
  1500.     InTeGer*4 DLFG
  1501. C    COMMON/DLFG/DLFG
  1502.     InTeGer*4 KDRW,KDCL
  1503. C    COMMON/DOT/KDRW,KDCL
  1504.     InTeGer*4 DTRENA
  1505. C    COMMON/DTRCMN/DTRENA
  1506.     REAL*8 EP,PV,FV
  1507.     DIMENSION EP(20)
  1508.     INTEGER*4 KIRR
  1509. C    COMMON/ERNPER/EP,PV,FV,KIRR
  1510.     InTeGer*4 LASTOP
  1511. C    COMMON/ERROR/LASTOP
  1512.     CHARACTER*1 FMTDAT(9,76)
  1513. C    COMMON/FMTBFR/FMTDAT
  1514.     CHARACTER*1 EDNAM(16)
  1515. C    COMMON/EDNAM/EDNAM
  1516.     InTeGer*4 MFID(2),MFMOD(2)
  1517. C    COMMON/FRM/MFID,MFMOD
  1518.     InTeGer*4 JMVFG,JMVOLD
  1519. C    COMMON/FUBAR/JMVFG,JMVOLD
  1520.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  1521.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  1522. C ***<<< KLSTO COMMON END >>>***
  1523. CCC    InTeGer*4 DTRENA
  1524. CCC    COMMON/DTRCMN/DTRENA
  1525.     CHARACTER *1 LINECL(82)
  1526. C    CHARACTER*70 LINEC
  1527.     EQUIVALENCE(LINEC(1:1),LINECL(1))
  1528. C    CHARACTER*80 SCRBUF
  1529.     CHARACTER*1 LBUF(128)
  1530.     CHARACTER*1 MBUF(128)
  1531.     CHARACTER*110 CLBUF,CMBUF
  1532.     CHARACTER*50 CCLBUF,CCMBUF
  1533.     CHARACTER*11 C11LBF
  1534. C    EQUIVALENCE(C11LBF(1:1),CLBUF(1:1))
  1535.     EQUIVALENCE(CLBUF(1:1),CCLBUF(1:1),LBUF(1),C11LBF(1:1)),
  1536.      1  (CMBUF(1:1),CCMBUF(1:1),MBUF(1))
  1537. C    EQUIVALENCE(CLBUF,LBUF(1)),(CMBUF,MBUF(1))
  1538. C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
  1539.     CHARACTER*9 FMTB
  1540.     EQUIVALENCE (FMTB(1:1),LBUF(120))
  1541.     CHARACTER*11 FMTBF
  1542.     CHARACTER*1 IFVLD
  1543. C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
  1544. ccc    DO 3332 N=1,80
  1545. ccc    NN=81-N
  1546. ccc    IF(ICHAR(LINE(NN)).GT.32)GOTO 3333
  1547. ccc    LINE(NN)=CHAR(0)
  1548. ccc3332    CONTINUE
  1549. ccc3333    CONTINUE
  1550. C SPACE FILL ENTIRE ARRAY
  1551.     DO 3334 N=1,82
  1552. 3334    LINECL(N)=CHAR(32)
  1553.     RETCD=1
  1554. C HANDLE DTRCMD FUNCTIONS. LINE ARRAY PASSED IN HERE
  1555. C STARTS AFTER THE "DTR" SO WE CAN DECODE IT.
  1556. C EXECUTE DTR COMMAND
  1557. C  DTRCMD (COMMAND) GIVES DTR COMMAND FACILITY AT COMMAND
  1558. C LEVEL.
  1559. C ALLOW DTRIMM COMMAND TO USE DTR IMMEDIATE TERMINAL
  1560. C INTERFACE. THE REST CAN USE SAME COMMAND NAMES AS AFTER
  1561. C THE "DB" IN *U DBXXXX COMMANDS.
  1562. 500    CONTINUE
  1563. C ENABLE/DISABLE FOR DTR FUNCTIONS
  1564. C SETTING DTRENA TO -1 IMPLIES DISABLE FUNCTIONS
  1565.     CALL SCMP(LINE,'ENA',3,ICODE)
  1566.     IF(ICODE.NE.1)GOTO 600
  1567.     DTRENA=1
  1568.     GOTO 9999
  1569. 600    CONTINUE
  1570.     CALL SCMP(LINE,'DIS',3,ICODE)
  1571.     IF(ICODE.NE.1)GOTO 700
  1572.     DTRENA=-1
  1573.     GOTO 9999
  1574. 700    CONTINUE
  1575.     CALL SCMP(LINE,'OPINS',5,ICODE)
  1576. C OPEN INPUT SEQUENTIAL
  1577.     IF(ICODE.NE.1)GOTO 3800
  1578. C DTROPINS RANGE FILENAME
  1579.     IBGN=6
  1580.     IVLD=0
  1581.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  1582.     IF(IVLD.EQ.3)GOTO 9990
  1583.     LINE(LSTCH+25)=CHAR(0)
  1584.     OPEN(UNIT=MFILUN,FILE=LINE(LSTCH),ACCESS='SEQUENTIAL',
  1585.      1  STATUS='OLD',IOSTAT=IVVV)
  1586.     IF(IVVV.NE.0)GOTO 9990
  1587.     MFIOPN=1
  1588.     GOTO 9999
  1589. 3800    CONTINUE
  1590.     CALL SCMP(LINE,'OPINRR',6,ICODE)
  1591. C OPEN IN RANDOM READ
  1592.     IF(ICODE.NE.1)GOTO 3900
  1593.     KK=2
  1594.     GOTO 3910
  1595. 3900    CONTINUE
  1596.     CALL SCMP(LINE,'OPINRU',6,ICODE)
  1597. C OPEN IN RANDOM UPDATE
  1598.     IF(ICODE.NE.1)GOTO 3950
  1599.     KK=3
  1600. 3910    CONTINUE
  1601. C HANDLE INPUT DIRECT ACCESS OPEN COMMONLY FOR READ ONLY AND R/W
  1602.     IBGN=7
  1603.     IVLD=0
  1604.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  1605.     IF(IVLD.EQ.3)GOTO 9990
  1606. C *******
  1607. C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
  1608.     DO 5601 NN=1,50
  1609. 5601    MBUF(NN)=' '
  1610.     DO 5602 NN=1,25
  1611. 5602    MBUF(NN)=LINE(LSTCH+NN-1)
  1612. C    LINE(LSTCH+25)=0
  1613. C    NBK=(MFIRH-MFIRL+1)*(MFICH-MFICL+1)
  1614. C    OPEN(UNIT=MFILUN,FILE=CCMBUF,ACCESS='BINARY',
  1615. C     1  INITIALSIZE=NBK,FORM='UNFORMATTED',STATUS='OLD',
  1616. C     1  RECL=128,BLOCKSIZE=128,ERR=9990)
  1617.     OPEN(UNIT=MFILUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  1618.      1  STATUS='OLD',FORM='UNFORMATTED',RECL=128,
  1619.      1  IOSTAT=IVVV)
  1620.     IF(IVVV.NE.0)GOTO 9990
  1621.     MFIOPN=KK
  1622.     GOTO 9999
  1623. 3950    CONTINUE
  1624.     CALL SCMP(LINE,'OPOUTS',6,ICODE)
  1625. C OPEN OUTPUT SEQUENTIAL
  1626.     IF(ICODE.NE.1)GOTO 4000
  1627.     IBGN=7
  1628.     IVLD=0
  1629.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  1630.     IF(IVLD.EQ.3)GOTO 9990
  1631. C *******
  1632. C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
  1633. C    LINE(LSTCH+25)=0
  1634.     DO 5603 NN=1,50
  1635. 5603    MBUF(NN)=' '
  1636.     DO 5604 NN=1,25
  1637. 5604    MBUF(NN)=LINE(LSTCH+NN-1)
  1638.     OPEN(UNIT=MFOLUN,FILE=CCMBUF(1:49),ACCESS='SEQUENTIAL',
  1639.      1  STATUS='NEW',IOSTAT=IVVV)
  1640.     IF(IVVV.NE.0)GOTO 9990
  1641.     MFOOPN=1
  1642.     GOTO 9999
  1643. 4000    CONTINUE
  1644.     CALL SCMP(LINE,'OPOUTR',6,ICODE)
  1645. C OPEN OUTPUT RANDOM
  1646.     IF(ICODE.NE.1)GOTO 4100
  1647.     IBGN=7
  1648.     IVLD=0
  1649.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  1650.     IF(IVLD.EQ.3)GOTO 9990
  1651. C    NBK=(MFORH-MFORL+1)*(MFOCH-MFOCL+1)
  1652. C *******
  1653. C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
  1654.     DO 5605 NN=1,50
  1655. 5605    MBUF(NN)=' '
  1656.     DO 5606 NN=1,25
  1657. 5606    MBUF(NN)=LINE(LSTCH+NN-1)
  1658. C    LINE(LSTCH+25)=0
  1659. C    OPEN(UNIT=MFOLUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  1660. C     1  INITIALSIZE=NBK,FORM='UNFORMATTED',STATUS='NEW',
  1661. C     1  RECL=32,BLOCKSIZE=128,ERR=9990)
  1662.     OPEN(UNIT=MFOLUN,FILE=CCMBUF,ACCESS='DIRECT',
  1663.      1  STATUS='NEW',FORM='UNFORMATTED',RECL=128,
  1664.      2  IOSTAT=IVVV)
  1665.     IF(IVVV.NE.0)GOTO 9990
  1666.     MFOOPN=2
  1667.     GOTO 9999
  1668. 4100    CONTINUE
  1669.     CALL SCMP(LINE,'CLSOUT',6,ICODE)
  1670. C CLOSE OUTPUT 
  1671.     IF(ICODE.NE.1)GOTO 4200
  1672.     CLOSE(UNIT=MFOLUN)
  1673.     MFOOPN=0
  1674.     GOTO 9999
  1675. 4200    CONTINUE
  1676.     CALL SCMP(LINE,'CLSINP',6,ICODE)
  1677. C CLOSE INPUT 
  1678.     IF(ICODE.NE.1)GOTO 4300
  1679.     CLOSE(UNIT=MFILUN)
  1680.     MFIOPN=0
  1681.     GOTO 9999
  1682. 4300    CONTINUE
  1683.     CALL SCMP(LINE,'ENAOUT',6,ICODE)
  1684. C ENABLE OUTPUT 
  1685.     IF(ICODE.NE.1)GOTO 4400
  1686.     MFOFLG=1
  1687.     GOTO 9999
  1688. 4400    CONTINUE
  1689.     CALL SCMP(LINE,'ENAINP',6,ICODE)
  1690. C ENABLE INPUT 
  1691.     IF(ICODE.NE.1)GOTO 4500
  1692.     MFIFLG=1
  1693.     GOTO 9999
  1694. 4500    CONTINUE
  1695.     CALL SCMP(LINE,'DISINP',6,ICODE)
  1696. C DISABLE INPUT 
  1697.     IF(ICODE.NE.1)GOTO 4510
  1698.     MFIFLG=0
  1699.     GOTO 9999
  1700. 4510    CONTINUE
  1701.     CALL SCMP(LINE,'DISOUT',6,ICODE)
  1702. C DISABLE OUTPUT
  1703.     IF(ICODE.NE.1)GOTO 4520
  1704.     MFOFLG=0
  1705.     GOTO 9999
  1706. 4520    CONTINUE
  1707.     CALL SCMP(LINE,'EDTINP',6,ICODE)
  1708. C ENABLE INPUT FORCE
  1709. C COMMAND
  1710. C DTREDTINP RANGE
  1711. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  1712. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  1713. C IT OUT AGAIN.
  1714.     IF(ICODE.NE.1)GOTO 4600
  1715. C FORCE ENABLE OF READIN DURING THIS
  1716.     MFIFLG=1
  1717.     MFOFLG=1
  1718. C ENABLE OUTPUT TOO.
  1719.     IBGN=7
  1720.     IVLD=0
  1721.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  1722.     IF(IVLD.EQ.3)GOTO 9990
  1723.     DO 4550 N1=IXRL,IXRH
  1724.     DO 4550 N2=IXCL,IXCH
  1725.     CALL REFLEC(N2,N1,IRX)
  1726. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  1727.     CALL FVLDST(N1,N2,Char(255))
  1728.     CALL WRKFIL(IRX,LBUF,0)
  1729.     CALL WRKFIL(IRX,LBUF,1)
  1730. 4550    CONTINUE
  1731.     MFIFLG=0
  1732.     MFOFLG=0
  1733.     GOTO 9999
  1734. 4600    CONTINUE
  1735.     CALL SCMP(LINE,'FMTOUT',6,ICODE)
  1736. C FORMAT/WRITE OUTPUT
  1737. C COMMAND
  1738. C DTRFMTOUT RANGE
  1739. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  1740. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  1741. C IT OUT AGAIN.
  1742.     IF(ICODE.NE.1)GOTO 4630
  1743.     IVLFG=1
  1744.     GOTO 4740
  1745. 4630    CONTINUE
  1746.     CALL SCMP(LINE,'VALOUT',6,ICODE)
  1747.     IF(ICODE.NE.1)GOTO 4700
  1748. C VALOUT CMD OUTPUTS VALUES WITH LONG D FORMAT
  1749.     IVFLG=2
  1750. C    GOTO 4740
  1751. 4740    CONTINUE
  1752. C FORCE ENABLE OF READIN DURING THIS
  1753.     MFIFLG=1
  1754.     MFOFLG=1
  1755. C ENABLE OUTPUT TOO.
  1756.     IBGN=7
  1757.     IVLD=0
  1758.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  1759.     IF(IVLD.EQ.3)GOTO 9990
  1760.     DO 4650 N1=IXRL,IXRH
  1761.     DO 4650 N2=IXCL,IXCH
  1762. C FIND INDEX FOR WRKFIL
  1763.     CALL REFLEC(N2,N1,IRX)
  1764. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  1765.     CALL XVBLGT(N1,N2,TMP)
  1766. C TMP IS REAL*8 SCRATCH
  1767.     CALL FVLDST(N1,N2,Char(255))
  1768.     CALL WRKFIL(IRX,LBUF,0)
  1769. C HAVING LOADED THE RECORD NOW (GETTING FORMAT, ETC.)
  1770. C NOW GRAB THE VALUE AND SAVE IT...
  1771. C FIRST MOVE THE FORMAT DOWN
  1772. C NOTE LINEC AND LINECL ARE EQUIVALENT BUT LINECL IS CHAR*1
  1773.     DO 4651 N=1,9
  1774.     LBUF(N+1)=LBUF(N+119)
  1775. 4651    CONTINUE
  1776.     LBUF(1)='('
  1777.     LBUF(11)=')'
  1778. c    LBUF(12)=CHAR(0)
  1779. C CHANGE TO USE CHAR VERSION OF LBUF
  1780. C *******
  1781. C FORMAT NOW LIVES IN LOW PART OF LBUF
  1782. C D25.17 FORMAT WOULD DO FOR WRITE
  1783. c    IF(IVLFG.EQ.1)WRITE(LINEC(1:70),C11LBF(1:11),ERR=4652)TMP
  1784.     IF(IVLFG.EQ.1)WRITE(LINEC(1:70),C11LBF,ERR=4652)TMP
  1785.     IF(IVLFG.EQ.2)WRITE(LINEC(1:70),4658,ERR=4652)TMP
  1786. 4658    FORMAT(D25.17)
  1787. C USE BUILTIN FORMAT TO WRITE THE VALUE IF COMMANDED TO DO SO OR
  1788. C USE DISPLAY FORMAT.
  1789. 4652    CONTINUE
  1790.     KK=1
  1791.     DO 4653 N=1,110
  1792. 4653    LBUF(N)=CHAR(0)
  1793.     DO 4654 N=1,60
  1794. C COPY LINECL CHARS TO LBUF, SKIPPING SPACES
  1795.     KKK=JCHAR(LINECL(N))
  1796.     IF(KKK.LE.32)GOTO 4654
  1797.     LBUF(KK)=LINECL(N)
  1798.     KK=KK+1
  1799. 4654    CONTINUE
  1800.     CALL WRKFIL(IRX,LBUF,1)
  1801. 4650    CONTINUE
  1802.     MFIFLG=0
  1803.     MFOFLG=0
  1804.     GOTO 9999
  1805. 4700    CONTINUE
  1806.     CALL SCMP(LINE,'CMPFRM',6,ICODE)
  1807.     IF(ICODE.NE.1)GOTO 4800
  1808. C DBCMPFRM V1:V2
  1809. C RETURNS IN % THE INDEX OF FORMULA 1 IN FORMULA 2
  1810.     IBGN=7
  1811.     IVLD=0
  1812. C USE GMTX TO GET CELL ADDRESSES.
  1813.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  1814.     IF(IVLD.EQ.3)GOTO 9990
  1815. C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
  1816.     CALL REFLEC(IXCL,IXRL,IRXL)
  1817.     CALL REFLEC(IXCH,IXRH,IRXH)
  1818.     IF(LINE(LSTCH).NE.',')GOTO 4780
  1819.     IBGN=LSTCH+1
  1820.     IVLD=0
  1821.     CALL GMTX(LINE,IBGN,LSTCH,IYRL,IYCL,IYRH,IYCH,IVLD)
  1822.     IF(IVLD.EQ.3)GOTO 4780
  1823. C GET THE LENGTHS NOW
  1824.     CALL XVBLGT(IYRL,IYCL,TMP)
  1825.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  1826.     LBUFL=TMP
  1827.     CALL XVBLGT(IYRH,IYCH,TMP)
  1828.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  1829.     MBUFL=TMP
  1830. C IF LENGTHS ARE OK FOR BOTH, THEN USE THEM AND DO THE
  1831. C COMPARISONS BASED ON THAT.
  1832.     GOTO 4770
  1833. 4780    CONTINUE
  1834. C GET INDEX OF EACH ELEMENT...
  1835.     CALL WRKFIL(IRXL,LBUF,0)
  1836.     CALL WRKFIL(IRXH,MBUF,0)
  1837. C LOAD THE 2 FORMULAS.
  1838. C NOW FIND THE ENDS...
  1839.     DO 4750 N=1,110
  1840.     NN=111-N
  1841.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4751
  1842. 4750    CONTINUE
  1843. 4751    LBUFL=NN
  1844.     DO 4760 N=1,110
  1845.     NN=111-N
  1846.     IF(JCHAR(MBUF(NN)).GT.32)GOTO 4761
  1847. 4760    CONTINUE
  1848. 4761    MBUFL=NN
  1849. 4770    CONTINUE
  1850. c find index pos'n by hand...
  1851.     KK=LBUFL-MBUFL+1
  1852.     DO 4776 NN=1,KK
  1853.     IF(LBUF(NN).NE.MBUF(1))GOTO 4776
  1854.     NNN=MBUFL-1
  1855.     DO 4777 N=1,NNN
  1856.     IVVV=NN+N
  1857.     IF (LBUF(IVVV).NE.MBUF(N+1))GOTO 4778
  1858. 4777    CONTINUE
  1859. C IF WE GALL THRU HERE ANYTIME WE HAVE A MATCH.
  1860. C SINCE NN IS WHAT WE NEED, GO USE IT.
  1861.     GOTO 4779
  1862. 4778    CONTINUE
  1863. 4776    CONTINUE
  1864. C IF NO MATCH, SET NN=0 TO SO FLAG IT AND BUG OUT.
  1865. C
  1866.     NN=0
  1867. 4779    CONTINUE
  1868. C NN IS LOCATION OF SUBSTRING NOW
  1869. C    NN=INDEX(CLBUF(1:LBUFL),CMBUF(1:MBUFL))
  1870. C NN IS LOCATION OF SUBSTRING NOW
  1871.     XAC=NN
  1872. C RETURN RESULT IN % ACCUMULATOR.
  1873.     WAC=0.
  1874.     IF(LLT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=-1.
  1875.     IF(LGT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=1.
  1876. C RETURN LESS/GREATER/EQUAL IN W ACCUMULATOR FOR POSSIBLE
  1877. C USE IN SORTS, ETC. THUS WE CAN TEST 2 STRINGS BY TESTING W ACCUM.
  1878. C (LEAVES X, Y ALONE SINCE W IS MORE FREQUENTLY FREE.)
  1879.     GOTO 9999
  1880. 4800    CONTINUE
  1881.     CALL SCMP(LINE,'LENFRM',6,ICODE)
  1882.     IF(ICODE.NE.1)GOTO 4900
  1883. C DBLENFRM V1:V2
  1884. C RETURNS LENGTH OF FORMULA IN V1 IN % AND V2
  1885.     IBGN=7
  1886.     IVLD=0
  1887. C USE GMTX TO GET CELL ADDRESSES.
  1888.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  1889.     IF(IVLD.EQ.3)GOTO 9990
  1890. C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
  1891.     CALL REFLEC(IXCL,IXRL,IRXL)
  1892. C GET INDEX OF EACH ELEMENT...
  1893.     CALL WRKFIL(IRXL,LBUF,0)
  1894. C LOAD THE FORMULA.
  1895. C NOW FIND THE END...
  1896.     DO 4850 N=1,110
  1897.     NN=111-N
  1898.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4851
  1899. 4850    CONTINUE
  1900. 4851    LBUFL=NN
  1901.     TMP=LBUFL
  1902.     XAC=TMP
  1903. C SAVE LENGTH IN OUTPUT CELL. DON'T TOUCH VALIDITY FOR THE CELL.
  1904.     NN=0
  1905. C SEE IF CELL IS VALID AND IF NOT VALID DON'T SAVE ANYTHING IN IT.
  1906.     CALL FVLDGT(IXRH,IXCH,NN)
  1907.     IF(NN.EQ.0)GOTO 9999
  1908.     CALL XVBLST(IXRH,IXCH,TMP)
  1909.     GOTO 9999
  1910. 4900    CONTINUE
  1911.     CALL SCMP(LINE,'TRMFRM',6,ICODE)
  1912.     IF(ICODE.NE.1)GOTO 5000
  1913. C TRIM FORMULA
  1914. C DTRTRMFRM INCELL:OUTCELL,START:END
  1915. C RETURNS TRIMMED FORMULA TO CELL.
  1916.     IBGN=7
  1917.     IVLD=0
  1918. C USE GMTX TO GET CELL ADDRESSES.
  1919.     CALL GMTX(LINE,IBGN,LSTCHR,IXRL,IXCL,IXRH,IXCH,IVLD)
  1920.     IF(IVLD.EQ.3)GOTO 9990
  1921. C GOT CELL HERE...BOTH FOR INPUT AND OUTPUT
  1922.     CALL REFLEC(IXCL,IXRL,IRXL)
  1923. C GET INDEX OF EACH ELEMENT...
  1924.     CALL REFLEC(IXCH,IXRH,IRXH)
  1925.     CALL WRKFIL(IRXL,LBUF,0)
  1926.     LO=LSTCHR+1
  1927.     LHI=LSTCHR+21
  1928.     LSTCHR=LHI
  1929.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  1930.     IF(IVLD.EQ.0)GOTO 9990
  1931.     CALL XVBLGT(JD1,JD2,TMP)
  1932.     LOCHR=1
  1933.     IF(TMP.GT.0..AND.TMP.LT.110.)LOCHR=TMP
  1934. C LOCHR = START CHAR
  1935.     LO=LSTCHR+1
  1936.     LHI=LSTCHR+21
  1937.     LSTCHR=LHI
  1938.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  1939.     IF(IVLD.EQ.0)GOTO 9990
  1940.     CALL XVBLGT(JD1,JD2,TMP)
  1941.     LHICHR=110
  1942.     IF(TMP.GT.0..AND.TMP.LT.110.)LHICHR=TMP
  1943. C LHICHR IS END CHARACTER
  1944. C NOW ALL ARGS ARE COLLECTED.
  1945. C (IGNORE WHAT WAS DELIMITER...)
  1946. C COPY DESIRED STUFF TO MBUF
  1947.     N=1
  1948.     DO 4910 NN=1,110
  1949.     MBUF(NN)=CHAR(0)
  1950.     IF(NN.LT.LOCHR.OR.NN.GT.LHICHR)GOTO 4910
  1951.     MBUF(N)=LBUF(NN)
  1952.     N=N+1
  1953. C COPY DESIRED PART OF FORMULA TO MBUF WITH THE REST ZEROED.
  1954. 4910    CONTINUE
  1955.     DO 4911 NN=111,128
  1956. 4911    MBUF(NN)=LBUF(NN)
  1957.     CALL WRKFIL(IRXH,MBUF,1)
  1958. C WRITE BUFFER BACK TO CELL AS TRIMMED NOW, GOING TO OUT CELL
  1959. C RATHER THAN INPUT CELL (TO ALLOW REPEATED CALCS TO BE STABLE.)
  1960.     GOTO 9999
  1961. 5000    CONTINUE
  1962.     GOTO 9999
  1963. 9990    RETCD=3
  1964. C ERROR RETURN
  1965. 9999    RETURN
  1966.     END
  1967. c -h- dtrfct.for    Fri Aug 22 13:05:02 1986    
  1968. C DATATRIEVE INTERFACE FUNCTIONS
  1969. C NON-DATATRIEVE PARTS, FOR MSDOS VERSION
  1970. C COPYRIGHT 1986 GCE
  1971.     SUBROUTINE DTRFCT(LINE,RETCD)
  1972.     InTeGer*4 RETCD
  1973.     CHARACTER*1 LINE(80)
  1974.     CHARACTER *1 LINECL(82)
  1975.     CHARACTER*62 LINEC
  1976.     EQUIVALENCE(LINEC(1:1),LINECL(1))
  1977. C
  1978. C
  1979. C DEFINE FILE AREAS FOR MAPPING FILES...
  1980. C
  1981. C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL)
  1982. C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED.
  1983. C
  1984. C MFIOPN =    0    IF NOT OPEN
  1985. C        1    IF OPEN FOR READ ONLY, SEQUENTIAL
  1986. C        2    IF OPEN READ ONLY, RANDOM
  1987. C        3    IF OPEN READ/WRITE, RANDOM.
  1988. C
  1989. C MFOOPN =    0    IF NOT OPEN
  1990. C        1    IF OPEN WRITE SEQUENTIAL
  1991. C        2    IF OPEN WRITE RANDOM
  1992. C
  1993. C OTHER OPTIONS DON'T MAKE SENSE.
  1994. C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE
  1995. C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE
  1996. C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS
  1997. C MFILUN,MFOLUN ARE LOGICAL UNITS.
  1998.     InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
  1999.     InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
  2000.     InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
  2001.     COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
  2002.      1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
  2003. C
  2004. C
  2005. C    INCLUDE 'VKLUGPRM.FTN'
  2006. C COPYRIGHT (C) 1983 GLENN EVERHART
  2007. C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS
  2008. C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY.
  2009.     CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
  2010.     InTeGer*4 TYPE(1,1),VLEN(9)
  2011.     REAL*8 XAC,XVBLS(1,1)
  2012.     REAL*8 TAC,UAC,VAC,WAC,YAC
  2013.     REAL*8 TMP
  2014.     INTEGER*4 JVBLS(2,1,1)
  2015.     EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
  2016.     EQUIVALENCE(XAC,AVBLS(1,27))
  2017.     EQUIVALENCE(TAC,AVBLS(1,20))
  2018.     EQUIVALENCE(UAC,AVBLS(1,21))
  2019.     EQUIVALENCE(VAC,AVBLS(1,22))
  2020.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  2021.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  2022.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  2023. C ***<<<< RDD COMMON START >>>***
  2024.     InTeGer*4 RRWACT,RCLACT
  2025. C    COMMON/RCLACT/RRWACT,RCLACT
  2026.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2027.      1  IDOL7,IDOL8
  2028. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2029. C     1  IDOL7,IDOL8
  2030.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2031. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2032.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2033. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2034. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2035. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2036.     InTeGer*4 KLVL
  2037. C    COMMON/KLVL/KLVL
  2038.     InTeGer*4 IOLVL,IGOLD
  2039. C    COMMON/IOLVL/IOLVL
  2040. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2041. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2042.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2043.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2044.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2045. C ***<<< RDD COMMON END >>>***
  2046. CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
  2047. CCC    CHARACTER*1 XTNCMD(80)
  2048. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  2049. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  2050. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  2051. CCC    InTeGer*4 RRWACT,RCLACT
  2052. CCC    COMMON/RCLACT/RRWACT,RCLACT
  2053. C ***<<< XVXTCD COMMON START >>>***
  2054.     CHARACTER*1 OARRY(100)
  2055.     InTeGer*4 OSWIT,OCNTR
  2056. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  2057. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  2058.     InTeGer*4 IPS1,IPS2,MODFLG
  2059. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  2060.        InTeGer*4 XTCFG,IPSET,XTNCNT
  2061.        CHARACTER*1 XTNCMD(80)
  2062. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  2063. C VARY FLAG ITERATION COUNT
  2064.     INTEGER KALKIT
  2065. C    COMMON/VARYIT/KALKIT
  2066.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  2067.     InTeGer*4 RCMODE,IRCE1,IRCE2
  2068. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  2069. C     1  IRCE2
  2070. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  2071. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  2072. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  2073. C RCFGX ON.
  2074. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  2075. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  2076. C  AND VM INHIBITS. (SETS TO 1).
  2077.     INTEGER*4 FH
  2078. C FILE HANDLE FOR CONSOLE I/O (RAW)
  2079. C    COMMON/CONSFH/FH
  2080.     CHARACTER*1 ARGSTR(52,4)
  2081. C    COMMON/ARGSTR/ARGSTR
  2082.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  2083.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  2084.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  2085.      3  IRCE2,FH,ARGSTR
  2086. C ***<<< XVXTCD COMMON END >>>***
  2087. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  2088. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  2089. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  2090. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  2091. C (IMPLEMENT FOR VAX ONLY)
  2092.     INTEGER IVVV
  2093. CCC    COMMON/VARYIT/KALKIT
  2094. C ARGUMENTS COME IN IN ARGUMENTS IN LINE
  2095. C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
  2096. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2097. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2098.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  2099.     COMMON/D2R/NRDSP,NCDSP
  2100. C ***<<< KLSTO COMMON START >>>***
  2101.     InTeGer*4 DLFG
  2102. C    COMMON/DLFG/DLFG
  2103.     InTeGer*4 KDRW,KDCL
  2104. C    COMMON/DOT/KDRW,KDCL
  2105.     InTeGer*4 DTRENA
  2106. C    COMMON/DTRCMN/DTRENA
  2107.     REAL*8 EP,PV,FV
  2108.     DIMENSION EP(20)
  2109.     INTEGER*4 KIRR
  2110. C    COMMON/ERNPER/EP,PV,FV,KIRR
  2111.     InTeGer*4 LASTOP
  2112. C    COMMON/ERROR/LASTOP
  2113.     CHARACTER*1 FMTDAT(9,76)
  2114. C    COMMON/FMTBFR/FMTDAT
  2115.     CHARACTER*1 EDNAM(16)
  2116. C    COMMON/EDNAM/EDNAM
  2117.     InTeGer*4 MFID(2),MFMOD(2)
  2118. C    COMMON/FRM/MFID,MFMOD
  2119.     InTeGer*4 JMVFG,JMVOLD
  2120. C    COMMON/FUBAR/JMVFG,JMVOLD
  2121.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  2122.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  2123. C ***<<< KLSTO COMMON END >>>***
  2124. CCC    InTeGer*4 DTRENA
  2125. CCC    COMMON/DTRCMN/DTRENA
  2126. C    CHARACTER*70 LINEC
  2127.     CHARACTER*1 LBUF(128)
  2128.     CHARACTER*1 MBUF(128)
  2129.     CHARACTER*110 CLBUF,CMBUF
  2130. C    EQUIVALENCE(CLBUF(1:1),LBUF(1)),(CMBUF(1:1),MBUF(1))
  2131.     CHARACTER*50 CCMBUF
  2132.     CHARACTER*11 C11LBF
  2133.     EQUIVALENCE(CCMBUF(1:1),CMBUF(1:1),MBUF(1)),
  2134.      1  (C11LBF(1:1),CLBUF(1:1),LBUF(1))
  2135. C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
  2136. c    CHARACTER*1 IFVLD
  2137.     RETCD=1
  2138.     IF(DTRENA.LT.0)GOTO 9999
  2139. C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
  2140. ccc    DO 3332 N=1,76
  2141. ccc    NN=77-N
  2142. ccc    IF(JCHAR(LINE(NN)).GT.32)GOTO 3333
  2143. ccc    LINE(NN)=CHAR(0)
  2144. ccc3332    CONTINUE
  2145. ccc3333    CONTINUE
  2146. C SPACE FILL ENTIRE ARRAY
  2147.     DO 3334 N=1,82
  2148. 3334    LINECL(N)=CHAR(32)
  2149.     RETCD=1
  2150. C HANDLE *U DBXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE
  2151. C STARTS AFTER THE "DB" SO WE CAN DECODE IT.
  2152. C *U DBCMD (COMMAND) PASSES COMMAND TO DTR FOR ACTION
  2153. C  HOWEVER THIS DOES NOT RETURN A VALUE. USE FOR
  2154. C  SETUP PURPOSES ONLY.
  2155. C
  2156. C NO NEED TO INCLUDE ABILITY TO STORE COMMANDS IN CELLS
  2157. C FOR EDITING SINCE {CELL CONSTRUCT PROVIDES THIS ALREADY.
  2158. C (AND AT COMMAND LEVEL THE __{CELL CONSTRUCT DOES ALSO.)
  2159. 500    CONTINUE
  2160.     CALL SCMP(LINE,'OPINS',5,ICODE)
  2161. C OPEN INPUT SEQUENTIAL
  2162.     IF(ICODE.NE.1)GOTO 3800
  2163. C DTROPINS RANGE FILENAME
  2164.     IBGN=6
  2165.     IVLD=0
  2166.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  2167.     IF(IVLD.EQ.3)GOTO 9990
  2168. C    LINE(LSTCH+25)=CHAR(0)
  2169.     DO 5601 NN=1,50
  2170. 5601    MBUF(NN)=' '
  2171.     DO 5602 NN=1,25
  2172. 5602    MBUF(NN)=LINE(LSTCH+NN-1)
  2173.     OPEN(UNIT=MFILUN,FILE=CCMBUF,ACCESS='SEQUENTIAL',
  2174.      1  STATUS='OLD',IOSTAT=IVVV)
  2175.     IF(IVVV.NE.0)GOTO 9990
  2176.     MFIOPN=1
  2177.     GOTO 9999
  2178. 3800    CONTINUE
  2179.     CALL SCMP(LINE,'OPINRR',6,ICODE)
  2180. C OPEN IN RANDOM READ
  2181.     IF(ICODE.NE.1)GOTO 3900
  2182.     KK=2
  2183.     GOTO 3910
  2184. 3900    CONTINUE
  2185.     CALL SCMP(LINE,'OPINRU',6,ICODE)
  2186. C OPEN IN RANDOM UPDATE
  2187.     IF(ICODE.NE.1)GOTO 3950
  2188.     KK=3
  2189. 3910    CONTINUE
  2190. C HANDLE INPUT DIRECT ACCESS OPEN COMMONLY FOR READ ONLY AND R/W
  2191.  
  2192.     IBGN=7
  2193.     IVLD=0
  2194.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  2195.     IF(IVLD.EQ.3)GOTO 9990
  2196. C    LINE(LSTCH+25)=0
  2197.     DO 5603 NN=1,50
  2198. 5603    MBUF(NN)=' '
  2199.     DO 5604 NN=1,25
  2200. 5604    MBUF(NN)=LINE(LSTCH+NN-1)
  2201. C    NBK=(MFIRH-MFIRL+1)*(MFICH-MFICL+1)
  2202.     OPEN(MFILUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  2203.      1  FORM='UNFORMATTED',RECL=128,STATUS='OLD',IOSTAT=IVVV)
  2204.     IF(IVVV.NE.0)GOTO 9990
  2205.     MFIOPN=KK
  2206.     GOTO 9999
  2207. 3950    CONTINUE
  2208.     CALL SCMP(LINE,'OPOUTS',6,ICODE)
  2209. C OPEN OUTPUT SEQUENTIAL
  2210.     IF(ICODE.NE.1)GOTO 4000
  2211.     IBGN=7
  2212.     IVLD=0
  2213.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  2214.     IF(IVLD.EQ.3)GOTO 9990
  2215.     DO 5605 NN=1,50
  2216. 5605    MBUF(NN)=' '
  2217.     DO 5606 NN=1,25
  2218. 5606    MBUF(NN)=LINE(LSTCH+NN-1)
  2219.     OPEN(UNIT=MFOLUN,FILE=CCMBUF,ACCESS='SEQUENTIAL',
  2220.      1  STATUS='NEW',IOSTAT=IVVV)
  2221.     IF(IVVV.NE.0)GOTO 9990
  2222.     MFOOPN=1
  2223.     GOTO 9999
  2224. 4000    CONTINUE
  2225.     CALL SCMP(LINE,'OPOUTR',6,ICODE)
  2226. C OPEN OUTPUT RANDOM
  2227.     IF(ICODE.NE.1)GOTO 4100
  2228.     IBGN=7
  2229.     IVLD=0
  2230.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  2231.     IF(IVLD.EQ.3)GOTO 9990
  2232. C    NBK=(MFORH-MFORL+1)*(MFOCH-MFOCL+1)
  2233. C    LINE(LSTCH+25)=0
  2234.     DO 5607 NN=1,50
  2235. 5607    MBUF(NN)=' '
  2236.     DO 5608 NN=1,25
  2237. 5608    MBUF(NN)=LINE(LSTCH+NN-1)
  2238.     OPEN(MFOLUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  2239.      1  STATUS='NEW',FORM='UNFORMATTED',RECL=128,
  2240.      2  IOSTAT=IVVV)
  2241.     IF(IVVV.NE.0)GOTO 9990
  2242.     MFOOPN=2
  2243.     GOTO 9999
  2244. 4100    CONTINUE
  2245.     CALL SCMP(LINE,'CLSOUT',6,ICODE)
  2246. C CLOSE OUTPUT 
  2247.     IF(ICODE.NE.1)GOTO 4200
  2248.     CLOSE(UNIT=MFOLUN)
  2249.     MFOOPN=0
  2250.     GOTO 9999
  2251. 4200    CONTINUE
  2252.     CALL SCMP(LINE,'CLSINP',6,ICODE)
  2253. C CLOSE INPUT 
  2254.     IF(ICODE.NE.1)GOTO 4300
  2255.     CLOSE(UNIT=MFILUN)
  2256.     MFIOPN=0
  2257.     GOTO 9999
  2258. 4300    CONTINUE
  2259.     CALL SCMP(LINE,'ENAOUT',6,ICODE)
  2260. C ENABLE OUTPUT 
  2261.     IF(ICODE.NE.1)GOTO 4400
  2262.     MFOFLG=1
  2263.     GOTO 9999
  2264. 4400    CONTINUE
  2265.     CALL SCMP(LINE,'ENAINP',6,ICODE)
  2266. C ENABLE INPUT 
  2267.     IF(ICODE.NE.1)GOTO 4500
  2268.     MFIFLG=1
  2269.     GOTO 9999
  2270. 4500    CONTINUE
  2271.     CALL SCMP(LINE,'DISINP',6,ICODE)
  2272. C DISABLE INPUT 
  2273.     IF(ICODE.NE.1)GOTO 4510
  2274.     MFIFLG=0
  2275.     GOTO 9999
  2276. 4510    CONTINUE
  2277.     CALL SCMP(LINE,'DISOUT',6,ICODE)
  2278. C DISABLE OUTPUT
  2279.     IF(ICODE.NE.1)GOTO 4520
  2280.     MFOFLG=0
  2281.     GOTO 9999
  2282. 4520    CONTINUE
  2283.     CALL SCMP(LINE,'EDTINP',6,ICODE)
  2284. C ENABLE INPUT FORCE
  2285. C COMMAND
  2286. C DTREDTINP RANGE
  2287. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  2288. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  2289. C IT OUT AGAIN.
  2290.     IF(ICODE.NE.1)GOTO 4600
  2291. C FORCE ENABLE OF READIN DURING THIS
  2292.     MFIFLG=1
  2293.     MFOFLG=1
  2294. C ENABLE OUTPUT TOO.
  2295.     IBGN=7
  2296.     IVLD=0
  2297.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  2298.     IF(IVLD.EQ.3)GOTO 9990
  2299.     DO 4550 N1=IXRL,IXRH
  2300.     DO 4550 N2=IXCL,IXCH
  2301.     CALL REFLEC(N2,N1,IRX)
  2302. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  2303.     CALL FVLDST(N1,N2,Char(255))
  2304.     CALL WRKFIL(IRX,LBUF,0)
  2305.     CALL WRKFIL(IRX,LBUF,1)
  2306. 4550    CONTINUE
  2307.     MFIFLG=0
  2308.     MFOFLG=0
  2309.     GOTO 9999
  2310. 4600    CONTINUE
  2311.     CALL SCMP(LINE,'FMTOUT',6,ICODE)
  2312. C FORMAT/WRITE OUTPUT
  2313. C COMMAND
  2314. C DTRFMTOUT RANGE
  2315. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  2316. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  2317. C IT OUT AGAIN.
  2318.     IF(ICODE.NE.1)GOTO 4630
  2319.     IVLFG=1
  2320.     GOTO 4740
  2321. 4630    CONTINUE
  2322.     CALL SCMP(LINE,'VALOUT',6,ICODE)
  2323.     IF(ICODE.NE.1)GOTO 4700
  2324. C VALOUT CMD OUTPUTS VALUES WITH LONG D FORMAT
  2325.     IVFLG=2
  2326. C    GOTO 4740
  2327. 4740    CONTINUE
  2328. C FORCE ENABLE OF READIN DURING THIS
  2329.     MFIFLG=1
  2330.     MFOFLG=1
  2331. C ENABLE OUTPUT TOO.
  2332.     IBGN=7
  2333.     IVLD=0
  2334.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  2335.     IF(IVLD.EQ.3)GOTO 9990
  2336.     DO 4650 N1=IXRL,IXRH
  2337.     DO 4650 N2=IXCL,IXCH
  2338. C FIND INDEX FOR WRKFIL
  2339.     CALL REFLEC(N2,N1,IRX)
  2340. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  2341.     CALL XVBLGT(N1,N2,TMP)
  2342. C TMP IS REAL*8 SCRATCH
  2343.     CALL FVLDST(N1,N2,Char(255))
  2344.     CALL WRKFIL(IRX,LBUF,0)
  2345. C HAVING LOADED THE RECORD NOW (GETTING FORMAT, ETC.)
  2346. C NOW GRAB THE VALUE AND SAVE IT...
  2347. C FIRST MOVE THE FORMAT DOWN
  2348. C NOTE LINEC AND LINECL ARE EQUIVALENT BUT LINECL IS CHAR*1
  2349.     DO 4651 N=1,9
  2350.     LBUF(N+1)=LBUF(N+119)
  2351. 4651    CONTINUE
  2352.     LBUF(1)='('
  2353.     LBUF(11)=')'
  2354. c    LBUF(12)=0
  2355. C FORMAT NOW LIVES IN LOW PART OF LBUF
  2356. C D25.17 FORMAT WOULD DO FOR WRITE
  2357. C NEED CHAR VBL FOR FORMAT EQUIV'D TO LOW 12 CHARS OF LBUF
  2358. c    IF(IVLFG.EQ.1)WRITE(LINEC(1:62),C11LBF(1:11),ERR=4652)TMP
  2359.     IF(IVLFG.EQ.1)WRITE(LINEC(1:62),C11LBF,ERR=4652)TMP
  2360.     IF(IVLFG.EQ.2)WRITE(LINEC(1:62),4658,ERR=4652)TMP
  2361. 4658    FORMAT(D25.17)
  2362. C USE BUILTIN FORMAT TO WRITE THE VALUE IF COMMANDED TO DO SO OR
  2363. C USE DISPLAY FORMAT.
  2364. 4652    CONTINUE
  2365.     KK=1
  2366.     DO 4653 N=1,110
  2367. 4653    LBUF(N)=CHAR(0)
  2368.     DO 4654 N=1,60
  2369. C COPY LINECL CHARS TO LBUF, SKIPPING SPACES
  2370.     KKK=JCHAR(LINECL(N))
  2371.     IF(KKK.LE.32)GOTO 4654
  2372.     LBUF(KK)=LINECL(N)
  2373.     KK=KK+1
  2374. 4654    CONTINUE
  2375.     CALL WRKFIL(IRX,LBUF,1)
  2376. 4650    CONTINUE
  2377.     MFIFLG=0
  2378.     MFOFLG=0
  2379.     GOTO 9999
  2380. 4700    CONTINUE
  2381.     CALL SCMP(LINE,'CMPFRM',6,ICODE)
  2382.     IF(ICODE.NE.1)GOTO 4800
  2383. C DBCMPFRM V1:V2
  2384. C RETURNS IN % THE INDEX OF FORMULA 1 IN FORMULA 2
  2385.     IBGN=7
  2386.     IVLD=0
  2387.     LSTCH=78
  2388. C USE GMTX TO GET CELL ADDRESSES.
  2389.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  2390.     IF(IVLD.EQ.3)GOTO 9990
  2391. C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
  2392.     CALL REFLEC(IXCL,IXRL,IRXL)
  2393.     CALL REFLEC(IXCH,IXRH,IRXH)
  2394.     IF(LINE(LSTCH).NE.',')GOTO 4780
  2395.     IBGN=LSTCH+1
  2396.     IVLD=0
  2397.     CALL GMTX(LINE,IBGN,LSTCH,IYRL,IYCL,IYRH,IYCH,IVLD)
  2398.     IF(IVLD.EQ.3)GOTO 4780
  2399. C GET THE LENGTHS NOW
  2400.     CALL XVBLGT(IYRL,IYCL,TMP)
  2401.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  2402.     LBUFL=TMP
  2403.     CALL XVBLGT(IYRH,IYCH,TMP)
  2404.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  2405.     MBUFL=TMP
  2406. C IF LENGTHS ARE OK FOR BOTH, THEN USE THEM AND DO THE
  2407. C COMPARISONS BASED ON THAT.
  2408.     GOTO 4770
  2409. 4780    CONTINUE
  2410. C GET INDEX OF EACH ELEMENT...
  2411.     CALL WRKFIL(IRXL,LBUF,0)
  2412.     CALL WRKFIL(IRXH,MBUF,0)
  2413. C LOAD THE 2 FORMULAS.
  2414. C NOW FIND THE ENDS...
  2415.     DO 4750 N=1,110
  2416.     NN=111-N
  2417.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4751
  2418. 4750    CONTINUE
  2419. 4751    LBUFL=NN
  2420.     DO 4760 N=1,110
  2421.     NN=111-N
  2422.     IF(JCHAR(MBUF(NN)).GT.32)GOTO 4761
  2423. 4760    CONTINUE
  2424. 4761    MBUFL=NN
  2425. 4770    CONTINUE
  2426. c find index pos'n by hand...
  2427.     KK=LBUFL-MBUFL+1
  2428.     DO 4776 NN=1,KK
  2429.     IF(LBUF(NN).NE.MBUF(1))GOTO 4776
  2430.     NNN=MBUFL-1
  2431.     DO 4777 N=1,NNN
  2432.     IVVV=NN+N
  2433.     IF (LBUF(IVVV).NE.MBUF(N+1))GOTO 4778
  2434. 4777    CONTINUE
  2435. C IF WE GALL THRU HERE ANYTIME WE HAVE A MATCH.
  2436. C SINCE NN IS WHAT WE NEED, GO USE IT.
  2437.     GOTO 4779
  2438. 4778    CONTINUE
  2439. 4776    CONTINUE
  2440. C IF NO MATCH, SET NN=0 TO SO FLAG IT AND BUG OUT.
  2441. C
  2442.     NN=0
  2443. 4779    CONTINUE
  2444. C NN IS LOCATION OF SUBSTRING NOW
  2445. C    NN=INDEX(CLBUF(1:LBUFL),CMBUF(1:MBUFL))
  2446.     XAC=NN
  2447. C RETURN RESULT IN % ACCUMULATOR.
  2448.     WAC=0.
  2449.     IF(LLT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=-1.
  2450.     IF(LGT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=1.
  2451. C RETURN LESS/GREATER/EQUAL IN W ACCUMULATOR FOR POSSIBLE
  2452. C USE IN SORTS, ETC. THUS WE CAN TEST 2 STRINGS BY TESTING W ACCUM.
  2453. C (LEAVES X, Y ALONE SINCE W IS MORE FREQUENTLY FREE.)
  2454.     GOTO 9999
  2455. 4800    CONTINUE
  2456.     CALL SCMP(LINE,'LENFRM',6,ICODE)
  2457.     IF(ICODE.NE.1)GOTO 4900
  2458. C DBLENFRM V1:V2
  2459. C RETURNS LENGTH OF FORMULA IN V1 IN % AND V2
  2460.     IBGN=7
  2461.     IVLD=0
  2462. C USE GMTX TO GET CELL ADDRESSES.
  2463.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  2464.     IF(IVLD.EQ.3)GOTO 9990
  2465.     CALL REFLEC(IXCL,IXRL,IRXL)
  2466. C GET INDEX OF EACH ELEMENT...
  2467.     CALL WRKFIL(IRXL,LBUF,0)
  2468. C LOAD THE FORMULA.
  2469. C NOW FIND THE END...
  2470.     DO 4850 N=1,110
  2471.     NN=111-N
  2472.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4851
  2473. 4850    CONTINUE
  2474. 4851    LBUFL=NN
  2475.     TMP=LBUFL
  2476.     XAC=TMP
  2477. C SAVE LENGTH IN OUTPUT CELL. DON'T TOUCH VALIDITY FOR THE CELL.
  2478.     NN=0
  2479. C SEE IF CELL IS VALID AND IF NOT VALID DON'T SAVE ANYTHING IN IT.
  2480.     CALL FVLDGT(IXRH,IXCH,NN)
  2481.     IF(NN.EQ.0)GOTO 9999
  2482.     CALL XVBLST(IXRH,IXCH,TMP)
  2483.     GOTO 9999
  2484. 4900    CONTINUE
  2485.     CALL SCMP(LINE,'TRMFRM',6,ICODE)
  2486.     IF(ICODE.NE.1)GOTO 5000
  2487. C TRIM FORMULA
  2488. C DTRTRMFRM INCELL:OUTCELL,START:END
  2489. C RETURNS TRIMMED FORMULA TO CELL.
  2490.     IBGN=7
  2491.     IVLD=0
  2492. C USE GMTX TO GET CELL ADDRESSES.
  2493.     CALL GMTX(LINE,IBGN,LSTCHR,IXRL,IXCL,IXRH,IXCH,IVLD)
  2494.     IF(IVLD.EQ.3)GOTO 9990
  2495. C GOT CELL HERE...BOTH FOR INPUT AND OUTPUT
  2496.     CALL REFLEC(IXCL,IXRL,IRXL)
  2497. C GET INDEX OF EACH ELEMENT...
  2498.     CALL REFLEC(IXCH,IXRH,IRXH)
  2499.     CALL WRKFIL(IRXL,LBUF,0)
  2500.     LO=LSTCHR+1
  2501.     LHI=LSTCHR+21
  2502.     LSTCHR=LHI
  2503.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  2504.     IF(IVLD.EQ.0)GOTO 9990
  2505.     CALL XVBLGT(JD1,JD2,TMP)
  2506.     LOCHR=1
  2507.     IF(TMP.GT.0..AND.TMP.LT.110.)LOCHR=TMP
  2508. C LOCHR = START CHAR
  2509.     LO=LSTCHR+1
  2510.     LHI=LSTCHR+21
  2511.     LSTCHR=LHI
  2512.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  2513.     IF(IVLD.EQ.0)GOTO 9990
  2514.     CALL XVBLGT(JD1,JD2,TMP)
  2515.     LHICHR=110
  2516.     IF(TMP.GT.0..AND.TMP.LT.110.)LHICHR=TMP
  2517. C LHICHR IS END CHARACTER
  2518. C NOW ALL ARGS ARE COLLECTED.
  2519. C (IGNORE WHAT WAS DELIMITER...)
  2520. C COPY DESIRED STUFF TO MBUF
  2521.     N=1
  2522.     DO 4910 NN=1,110
  2523.     MBUF(NN)=CHAR(0)
  2524.     IF(NN.LT.LOCHR.OR.NN.GT.LHICHR)GOTO 4910
  2525.     MBUF(N)=LBUF(NN)
  2526.     N=N+1
  2527. C COPY DESIRED PART OF FORMULA TO MBUF WITH THE REST ZEROED.
  2528. 4910    CONTINUE
  2529.     DO 4911 NN=111,128
  2530. 4911    MBUF(NN)=LBUF(NN)
  2531.     CALL WRKFIL(IRXH,MBUF,1)
  2532. C WRITE BUFFER BACK TO CELL AS TRIMMED NOW, GOING TO OUT CELL
  2533. C RATHER THAN INPUT CELL (TO ALLOW REPEATED CALCS TO BE STABLE.)
  2534.     GOTO 9999
  2535. 5000    CONTINUE
  2536.     GOTO 9999
  2537. 9990    RETCD=3
  2538. C ERROR RETURN
  2539. 9999    RETURN
  2540.     END
  2541. c -h- fft.ftn    Fri Aug 22 13:08:56 1986    
  2542. C  
  2543. C-----------------------------------------------------------------------
  2544. C SUBROUTINE: FOUREA
  2545. C PERFORMS COOLEY-TUKEY FAST FOURIER TRANSFORM
  2546. C-----------------------------------------------------------------------
  2547. C  
  2548.       SUBROUTINE FOUREA(ID1,ID2,IC,IR,IVN,ISI)
  2549. C ID1,ID2 = COORDS OF FIRST CELL. IC AND IR ARE 0, OR 1
  2550. C ONLY ONE OF IC, IR MAY BE NONZERO. (FLAGS HORIZ/VERTICAL
  2551. C DATA AREA)
  2552. C  
  2553. C THE COOLEY-TUKEY FAST FOURIER TRANSFORM IN ANSI FORTRAN
  2554. C  
  2555. C DATA IS A ONE-DIMENSIONAL COMPLEX ARRAY WHOSE LENGTH, N, IS A
  2556. C POWER OF TWO.  ISI IS +1 FOR AN INVERSE TRANSFORM AND -1 FOR A
  2557. C FORWARD TRANSFORM.  TRANSFORM VALUES ARE RETURNED IN THE INPUT
  2558. C ARRAY, REPLACING THE INPUT.
  2559. C TRANSFORM(J)=SUM(DATA(I)*W**((I-1)*(J-1))), WHERE I AND J RUN
  2560. C FROM 1 TO N AND W = EXP (ISI*2*PI*SQRT(-1)/N).  PROGRAM ALSO
  2561. C COMPUTES INVERSE TRANSFORM, FOR WHICH THE DEFINING EXPRESSION
  2562. C IS INVTR(J)=(1/N)*SUM(DATA(I)*W**((I-1)*(J-1))).
  2563. C RUNNING TIME IS PROPORTIONAL TO N*LOG2(N), RATHER THAN TO THE
  2564. C CLASSICAL N**2.
  2565. C AFTER PROGRAM BY BRENNER, JUNE 1967. THIS IS A VERY SHORT VERSION
  2566. C OF THE FFT AND IS INTENDED MAINLY FOR DEMONSTRATION. PROGRAMS
  2567. C ARE AVAILABLE IN THIS COLLECTION WHICH RUN FASTER AND ARE NOT
  2568. C RESTRICTED TO POWERS OF 2 OR TO ONE-DIMENSIONAL ARRAYS.
  2569. C SEE -- IEEE TRANS AUDIO (JUNE 1967), SPECIAL ISSUE ON FFT.
  2570. C  
  2571. C ASSUMES THAT FIRST N/2 ELEMENTS ARE REAL, SECOND COMPLEX...
  2572. C STORES DATA THAT WAY ALSO...
  2573. C
  2574. C      COMPLEX DATA(1)
  2575. C      COMPLEX TEMP, W
  2576. C MAKE THIS A REAL FFT, NOT COMPLEX...
  2577.     REAL*8 DATA(1),TEMP,W,TEMP2,TEMPI,WI
  2578.     InTeGer*4 ID1,ID2,IC,IR,IRX,IRXX,IVN,N
  2579. C SET UP STMT FUNCTIONS...
  2580.     ID1F(K)=ID1+IC*(K-1)
  2581.     ID2F(K)=ID2+IR*(K-1)
  2582.     N=IVN
  2583. C  
  2584. C CHECK FOR POWER OF TWO UP TO 14
  2585. C  
  2586. C INITIALLY SAY ALL OK
  2587.       NN = 1
  2588.       DO 10 I=1,14
  2589.         M = I
  2590.         NN = NN*2
  2591.         IF (NN.EQ.N) GO TO 20
  2592.     IF(NN.GT.N)GOTO 11
  2593.   10  CONTINUE
  2594. 11    CONTINUE
  2595.     N=NN/2
  2596. C USE NEXT SMALLER POWER OF 2 ARRAY...
  2597. C    RETURN
  2598. C HERE BEGINNETH ACTUAL WORK.
  2599. C SET UP DATA COORDS ON THE FLY. NORMALLY I,J RUN IN RANGE 1 TO N
  2600. C SO WHERE K=(I OR J) (I.E., ONE OF THE TWO) WE USE A RELATION
  2601. C ID1V=ID1+IC*(K-1) AND ID2V=ID2+IR*(K-1). WE USE STMT FUNCTIONS
  2602. C ID1F AND ID2F FOR THIS.
  2603.   20  CONTINUE
  2604.     NOV2=N/2
  2605. C  
  2606. C      PI = 4.*ATAN(1.)
  2607.     PI=3.14159265358979323846264
  2608.       FN = NOV2
  2609. C  
  2610. C THIS SECTION PUTS DATA IN BIT-REVERSED ORDER
  2611. C  
  2612.       J = 1
  2613.       DO 80 I=1,NOV2
  2614. C  
  2615. C AT THIS POINT, I AND J ARE A BIT REVERSED PAIR (EXCEPT FOR THE
  2616. C DISPLACEMENT OF +1)
  2617. C  
  2618.     IF(I.GE.J)GOTO 40
  2619. C  
  2620. C EXCHANGE DATA(I) WITH DATA(J) IF I.LT.J.
  2621. C  
  2622.  30    CONTINUE
  2623. C EXCHANGE DATA(J), DATA(I)
  2624.     CALL XVBLGT(ID1F(J),ID2F(J),TEMP)
  2625.     CALL XVBLGT(ID1F(I),ID2F(I),DATA(1))
  2626.     CALL XVBLST(ID1F(J),ID2F(J),DATA(1))
  2627.     CALL XVBLST(ID1F(I),ID2F(I),TEMP)
  2628. C FLIP BOTH REAL AND COMPLEX PARTS OF DATA
  2629.     CALL XVBLGT(ID1F(J+NOV2),ID2F(J+NOV2),TEMP)
  2630.     CALL XVBLGT(ID1F(I+NOV2),ID2F(I+NOV2),DATA(1))
  2631.     CALL XVBLST(ID1F(J+NOV2),ID2F(J+NOV2),DATA(1))
  2632.     CALL XVBLST(ID1F(I+NOV2),ID2F(I+NOV2),TEMP)
  2633. C  30    TEMP = DATA(J)
  2634. C        DATA(J) = DATA(I)
  2635. C        DATA(I) = TEMP
  2636. C  
  2637. C IMPLEMENT J=J+1, BIT-REVERSED COUNTER
  2638. C  
  2639.   40    M = NOV2/2
  2640.   50    IF (J.LE.M) GOTO 70
  2641.   60    J = J - M
  2642.         M = (M+1)/2
  2643.         GO TO 50
  2644.   70    J = J + M
  2645.   80  CONTINUE
  2646. C  
  2647. C NOW COMPUTE THE BUTTERFLIES
  2648. C  
  2649.       MMAX = 1
  2650.   90  IF (MMAX.GE.NOV2)GOTO 130
  2651.  100  ISTEP = 2*MMAX
  2652.       DO 120 M=1,MMAX
  2653.         THETA = PI*FLOAT(ISI*(M-1))/FLOAT(MMAX)
  2654.      W = COS(THETA)
  2655.         WI = SIN(THETA)
  2656. C        W = CMPLX(COS(THETA),SIN(THETA))
  2657.         DO 110 I=M,NOV2,ISTEP
  2658.           J = I + MMAX
  2659. C GET REAL AND IMAG HALVES OF NUMBER...
  2660.       CALL XVBLGT(ID1F(J),ID2F(J),TEMP)
  2661.       CALL XVBLGT(ID1F(J+NOV2),ID2F(J+NOV2),TEMPI)
  2662. C DO COMPLEX MULTIPLICATION BY HAND TO AVOID LARGE RUNTIME SYSTEM
  2663. C ROUTINE INCLUSION.
  2664.       TEMP2=W*TEMP-WI*TEMPI
  2665.       TEMPI=WI*TEMP+W*TEMPI
  2666.     TEMP=TEMP2
  2667. C          TEMP = W*DATA(J)
  2668. C          DATA(J) = DATA(I) - TEMP
  2669. C          DATA(I) = DATA(I) + TEMP
  2670.        CALL XVBLGT(ID1F(I),ID2F(I),DATA(1))
  2671.        TEMP2=DATA(1)+TEMP
  2672.        DATA(1)=DATA(1) - TEMP
  2673.        CALL XVBLST(ID1F(J),ID2F(J),DATA(1))
  2674.        CALL XVBLST(ID1F(I),ID2F(I),TEMP2)
  2675. C COMPLEX PART
  2676.        CALL XVBLGT(ID1F(I+NOV2),ID2F(I+NOV2),DATA(1))
  2677.        TEMP2=DATA(1)+TEMPI
  2678.        DATA(1)=DATA(1) - TEMPI
  2679.        CALL XVBLST(ID1F(J+NOV2),ID2F(J+NOV2),DATA(1))
  2680.        CALL XVBLST(ID1F(I+NOV2),ID2F(I+NOV2),TEMP2)
  2681.  110    CONTINUE
  2682.  120  CONTINUE
  2683.       MMAX = ISTEP
  2684.       GO TO 90
  2685.   130  IF (ISI.LT.0) GOTO 160
  2686. C  
  2687. C FOR INV TRANS -- ISI=1 -- MULTIPLY OUTPUT BY 1/N
  2688. C  
  2689.  140  DO 150 I=1,N
  2690. C        DATA(I) = DATA(I)/FN
  2691.     CALL XVBLGT(ID1F(I),ID2F(I),TEMP)
  2692.     TEMP=TEMP/FN
  2693.     CALL XVBLST(ID1F(I),ID2F(I),TEMP)
  2694.  150  CONTINUE
  2695.  160  RETURN
  2696.       END
  2697. c -h- help.for    Fri Aug 22 13:20:10 1986    
  2698.     SUBROUTINE HELP(LVL)
  2699. C PRINT HELP INFO ON SCREEN USING FIRST 22 LINES. ASSUME XQTCMD INVALIDATES
  2700. C THE DISPLAY.
  2701. C COPYRIGHT (C) 1983 GLENN AND MARY EVERHART
  2702.     CHARACTER*1 FORM(128)
  2703.     CALL UVT100(18,0,0)
  2704.     CALL UVT100(11,2,0)
  2705.     CALL UVT100(1,1,1)
  2706. C COPYRIGHT (C) 1983 GLENN and MARY EVERHART
  2707. C All Rights Reserved
  2708. C
  2709. C NEW PC HELP FILE
  2710. C DESIGNED TO BE SMALLER THAN OLD VERSION. READS FILES OFF DISK
  2711. C BY SKIPPING N*24 LINES AND DISPLAYING 24 LINES, WHERE N=LVL
  2712. C ASSUME HELP FILE ON DISK LOGGED CURRENTLY
  2713.     CLOSE(3)
  2714. c for now, assume help file lives on same disk as our default.
  2715.     IXXX=0
  2716.     OPEN(3,FILE='PCCHELP.HLP',STATUS='OLD',ACCESS='DIRECT',
  2717.      1  FORM='UNFORMATTED',RECL=128,IOSTAT=IXXX)
  2718.     IF(IXXX.GT.0)RETURN
  2719. C RETURN IF HELP FILE IS MISSING...
  2720. C USE A FIXED HELP FILE FOR MULTISCREEN HELP. LOWER OVERHEAD,...
  2721.     NSKP=LVL*24
  2722. C NOW READ IN THE DATA, WRITE TO SCREEN.
  2723.     KKL=NSKP+1
  2724.     KKH=NSKP+23
  2725. C JUST GO DIRECTLY TO THE DESIRED SCREENFUL OF INFO.
  2726.     DO 7640 KKK=KKL,KKH
  2727.     READ(3,REC=KKK,END=7642,ERR=7642)FORM
  2728. c use fortran writes here normally since we want the crlf stuff they imply
  2729. c always write 24 lines to scroll all else off...
  2730.     IVVV=78
  2731. C FIND END OF LINE AND ONLY EMIT CHARACTERS TO THAT; DON'T WASTE
  2732. C TIME DRAWING SPACES ON THE SCREEN.
  2733.     DO 772 IV=1,78
  2734.     IVVV=79-IV
  2735.     IF(ICHAR(FORM(IVVV)).GT.32)GOTO 773
  2736. 772    CONTINUE
  2737. 773    CONTINUE
  2738.     FORM(IVVV+1)=Char(13)
  2739.     FORM(IVVV+2)=Char(10)
  2740.     IVVV=IVVV+2
  2741.     CALL SWRT(FORM,IVVV)
  2742. C    WRITE(11,7643)(FORM(IV),IV=1,IVVV)
  2743. C NOTE WE HAVE LUN 6 OPENED AS CON: IN THE MAIN PROGRAM TO GIVE AN
  2744. C INDEPENDENT TERMINAL OUTPUT CHANNEL. HOPEFULLY THIS PREVENTS SOME
  2745. C SCREWUPS DUE TO USING LUN 0 FOR BOTH CONSOLE INPUT AND OUTPUT; END OF
  2746. C RECORDS OUGHT TO BE INDEPENDENT THIS WAY (I HOPE).
  2747. C7643    FORMAT(1X,82A1,4A1)
  2748. 7640    CONTINUE
  2749. 7642    CONTINUE
  2750.     CLOSE(3)
  2751.     FORM(1)=13
  2752.     CALL SWRT(FORM,1)
  2753.     RETURN
  2754.     END
  2755. c -h- linfit.for    Fri Aug 22 13:23:55 1986    
  2756. C LINE FITTING SUBROUTINE WITH ERROR MEASURE RETURN ALSO.
  2757.     SUBROUTINE LINFIT(ID1X,ID2X,IRCOL,ID1,ID2,N,A,B,DEL,RR)
  2758.     InTeGer*4 ID1X,ID2X,IRCOL,ID1,ID2,N
  2759.     REAL*8 A,B,DEL,XY,SX2,SX,SY,RR
  2760.     InTeGer*4 IC,IR,KK,KKK,I
  2761.     REAL*8 XI,YI,SY2,EN,WRK
  2762. C FIT LINE TO EQUALLY SPACED POINTS...
  2763. C Y=BX+A
  2764.     SY2=0.
  2765.     EN=N
  2766.     XY=0.
  2767.     SX2=0.
  2768.     SX=0.
  2769.     SY=0.
  2770.     IC=IRCOL
  2771.     IR=1-IRCOL
  2772. C IRCOL IS 0 OR 1 FOR ACROSS OR DOWN
  2773.     DO 10 I=1,N
  2774. C IF ID1X < 0 THEN FORM IT HERE AS ID1+I-1
  2775.     IF (ID1X.GT.0)GOTO 20
  2776. C FORM XI
  2777.     XI=I
  2778.     GOTO 30
  2779. 20    CONTINUE
  2780. C INPUT XI
  2781.     KK=ID1X+IC*(I-1)
  2782.     KKK=ID2X+IR*(I-1)
  2783.     CALL XVBLGT(KK,KKK,XI)
  2784. 30    CONTINUE
  2785. C GET YI IN ANY CASE...
  2786.     KK=ID1+IC*(I-1)
  2787.     KKK=ID2+IR*(I-1)
  2788.     CALL XVBLGT(KK,KKK,YI)
  2789.     XY=XY+XI*YI
  2790. C FORM SUMS NEEDED TO FIT LINE...
  2791.     SX2=SX2+XI*XI
  2792.     SX=SX+XI
  2793.     SY=SY+YI
  2794.     SY2=SY2+YI*YI
  2795. 10    CONTINUE
  2796. C NOW GET SLOPE
  2797.     WRK=((XY-(SX*SY)/EN)/(SX2-(SX*SX)/EN))
  2798.     B=WRK
  2799. C THEN INTERCEPT
  2800.     WRK=(SY/EN)-B*(SX/EN)
  2801.     A=WRK
  2802.     WRK=DSQRT((SY2-(A*SY+B*XY))/EN)
  2803.     DEL=WRK
  2804. C DEL = ERROR OF FIT
  2805.     RR=(EN*XY-SX*SY)/DSQRT((EN*SX2-SX*SX)*(EN*SY2-SY*SY))
  2806. C RR IS CORRELATION COEFFICIENT
  2807.     RETURN
  2808.     END
  2809. c -h- list.for    Fri Aug 22 13:24:14 1986    
  2810.     SUBROUTINE LIST
  2811. C COPYRIGHT (C) 1983 GLENN EVERHART
  2812. C ALL RIGHTS RESERVED
  2813. C 60=MAX REAL ROWS
  2814. C 301=MAX REAL COLS
  2815. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  2816. C VBLS AND TYPE DIMENSIONED 60,301
  2817. C **************************************************
  2818. C *                                                *
  2819. C *              SUBROUTINE  LIST                  *
  2820. C *                                                *
  2821. C **************************************************
  2822. C
  2823. C
  2824. C LISTS THE LEGAL CALC COMMANDS AND GIVES A BRIEF
  2825. C DESCRIPTION OF THEIR FUNCTION.
  2826. C
  2827. C LIST IS CALLED BY CALC
  2828. C
  2829. C    SUBROUTINE LIST
  2830. C
  2831. C
  2832. C NOTE WE USE FORTRAN WRITE HERE SINCE IT SHOULD ONLY HAPPEN IN CALC MODE.
  2833.     WRITE (11,20)
  2834.     WRITE (11,30)
  2835.     RETURN
  2836. 20    FORMAT (' CMDS= @FILE-DO FILE;*C-COMMENT;*E-EXIT;*R-READ CON')
  2837. 30    FORMAT (' *S-STOP;*V n(bet.0,3)-VIEW CTL- HIGHER=SEE MORE')
  2838.     END
  2839. c -h- wsset.f40    Fri Aug 22 13:43:11 1986    
  2840.         SUBROUTINE WSSET
  2841. C WORK SHEET MANAGMENT ROUTINES
  2842. C HANDLE SPREADSHEET "IN MEMORY" STORAGE
  2843. C COPYRIGHT (C) GLENN AND MARY EVERHART 1983,1984
  2844. C
  2845. C ALL RIGHTS RESERVED
  2846. C
  2847. C WSSET - INITIALIZE STORAGE TO START CONDITIONS
  2848. C EXPECT IMPLEMENTATION TO USE A COMMON BITMAP AND PROVIDE A VARIABLE
  2849. C NCEL TO TELL HOW MANY CELLS ARE IN USE
  2850. C NEXT BITMAPS IMPLEMENT FVLD
  2851.         CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
  2852.     CHARACTER*1 FVXX(6792)
  2853.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
  2854.     EQUIVALENCE (FV4(1),FVXX(4529))
  2855.         Common/FVLDM/FVXX
  2856. c        COMMON/FVLDM/FV1,FV2,FV4
  2857. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  2858. C TYPES OF AC'S STORAGE:
  2859.         CHARACTER*1 ITYP(2264)
  2860.         InTeGer*4 IATYP(27),LINTGR
  2861.         COMMON/TYP/IATYP,ITYP,LINTGR
  2862.         CHARACTER*1 LBITS(8)
  2863.         COMMON/BITS/LBITS
  2864. C ***<<<< RDD COMMON START >>>***
  2865.     InTeGer*4 RRWACT,RCLACT
  2866. C    COMMON/RCLACT/RRWACT,RCLACT
  2867.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2868.      1  IDOL7,IDOL8
  2869. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2870. C     1  IDOL7,IDOL8
  2871.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2872. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2873.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2874. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2875. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2876. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2877.     InTeGer*4 KLVL
  2878. C    COMMON/KLVL/KLVL
  2879.     InTeGer*4 IOLVL,IGOLD
  2880. C    COMMON/IOLVL/IOLVL
  2881. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2882. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2883.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2884.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2885.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2886. C ***<<< RDD COMMON END >>>***
  2887. CCC        InTeGer*4 IPGMAX,LPGMXF
  2888. CCC        COMMON/FILEMX/IPGMAX,LPGMXF
  2889. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2890. C USE LUN 7 FOR FORMULAS, 9 FOR VALUES FILE IF NEEDED...
  2891. C
  2892. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  2893. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  2894. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  2895. C AREAS WITH DATA.
  2896. C ***<<< KLSTO COMMON START >>>***
  2897.     InTeGer*4 DLFG
  2898. C    COMMON/DLFG/DLFG
  2899.     InTeGer*4 KDRW,KDCL
  2900. C    COMMON/DOT/KDRW,KDCL
  2901.     InTeGer*4 DTRENA
  2902. C    COMMON/DTRCMN/DTRENA
  2903.     REAL*8 EP,PV,FV
  2904.     DIMENSION EP(20)
  2905.     INTEGER*4 KIRR
  2906. C    COMMON/ERNPER/EP,PV,FV,KIRR
  2907.     InTeGer*4 LASTOP
  2908. C    COMMON/ERROR/LASTOP
  2909.     CHARACTER*1 FMTDAT(9,76)
  2910. C    COMMON/FMTBFR/FMTDAT
  2911.     CHARACTER*1 EDNAM(16)
  2912. C    COMMON/EDNAM/EDNAM
  2913.     InTeGer*4 MFID(2),MFMOD(2)
  2914. C    COMMON/FRM/MFID,MFMOD
  2915.     InTeGer*4 JMVFG,JMVOLD
  2916. C    COMMON/FUBAR/JMVFG,JMVOLD
  2917.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  2918.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  2919. C ***<<< KLSTO COMMON END >>>***
  2920. CCC        CHARACTER*1 FMTDAT(9,76)
  2921. CCC        COMMON/FMTBFR/FMTDAT
  2922.         CHARACTER*1 DVF(12),DFMT(10)
  2923.         EQUIVALENCE(DVF(2),DFMT(1))
  2924.         COMMON/DEFVBX/DVF
  2925. CCC    InTeGer*4 DLFG
  2926. CCC    COMMON/DLFG/DLFG
  2927. C DLFG IS NONZERO IF ANY D## FORMS HAVE BEEN SEEN
  2928.         InTeGer*4 MPAG(2),MPMOD
  2929.         InTeGer*2 LVALBF(5,800)
  2930.     DIMENSION MPMOD(2)
  2931.         COMMON/VB/MPAG,LVALBF,MPMOD
  2932.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  2933.     COMMON/VBCTL/MFLAST,MFBASE,MVLASE,MVBASE
  2934. CCC    InTeGer*4 MFID(2)
  2935. C        InTeGer*4 MFID,IFID(8,2048)
  2936. C        CHARACTER*1 LFID(16,2048)
  2937. C        EQUIVALENCE(IFID(1,1),LFID(1,1))
  2938. CCC        COMMON/FRM/MFID,MFMOD
  2939. C        COMMON/FRM/MFID,IFID
  2940. C
  2941. C ***<<< NULETC COMMON START >>>***
  2942.     InTeGer*4 ICREF,IRREF
  2943. C    COMMON/MIRROR/ICREF,IRREF
  2944.     InTeGer*4 MODPUB,LIMODE
  2945. C    COMMON/MODPUB/MODPUB,LIMODE
  2946.     InTeGer*4 KLKC,KLKR
  2947.     REAL*8 AACP,AACQ
  2948. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  2949.     InTeGer*4 NCEL,NXINI
  2950. C    COMMON/NCEL/NCEL,NXINI
  2951.     CHARACTER*1 NAMARY(20,301)
  2952. C    COMMON/NMNMNM/NAMARY
  2953.     InTeGer*4 NULAST,LFVD
  2954. C    COMMON/NULXXX/NULAST,LFVD
  2955.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  2956.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  2957. C ***<<< NULETC COMMON END >>>***
  2958. CCC        COMMON /NCEL/NCEL,NXINI
  2959.     LINTGR=0
  2960.     MPMOD(1)=0
  2961.     MPMOD(2)=0
  2962.     MFMOD(1)=0
  2963.     MFMOD(2)=0
  2964.     DLFG=0
  2965.         IBP=1
  2966. C INITIALIZE ADDRESSES FOR FVLDSG/FVLDGT
  2967. C    CALL FVGO(FV1,LBITS)
  2968.         DO 2 N=1,9
  2969. 2       FMTDAT(N,1)=DFMT(N)
  2970.         DO 3 N=2,76
  2971.         DO 3 NN=1,9
  2972. 3       FMTDAT(NN,N)=CHAR(0)
  2973.         DO 1 N=1,8
  2974.     NN=128/IBP
  2975.         LBITS(N)=CHAR(NN)
  2976. 1       IBP=IBP+IBP
  2977.         DO 4 N=1,2264
  2978. C CLEAR BITMAPS NOW
  2979.         FV1(N)=CHAR(0)
  2980.         FV2(N)=CHAR(0)
  2981.         FV4(N)=CHAR(0)
  2982. 4       ITYP(N)=CHAR(0)
  2983. C OPEN THE WORK FILES SO WE DON'T NEED TO LATER...
  2984. C LUN 7 IS FORMULAS; LUN 9 IS VALUES
  2985. C HOWEVER, IF IPGMAX IS LESS THAN 800/205 (INDICATING ENTIRE FILE
  2986. C FITS IN MEMORY) DON'T OPEN LUN 9 AND IF LPGMXF IS < 2048/64, LIKEWISE
  2987. C FOR LUN 7.
  2988. C INITIALLY CLOSE FILES IN CASE THEY WERE OPEN...
  2989.         CLOSE(7,STATUS='DELETE')
  2990.         CLOSE(13,STATUS='DELETE')
  2991. C NOW OPEN THEM AS RANDOM ACCESS FILES.
  2992.         NBK=IPGMAX*2
  2993. C KEEP VALUE PAGES IN 500 BYTE UNITS, NOT 512 BYTE UNITS, TO COME
  2994. C OUT EVEN...
  2995.         IF(IPGMAX.GT.(800/100))OPEN(13,
  2996.      1  ACCESS='DIRECT',FORM='UNFORMATTED',
  2997.      3  RECL=500,STATUS='NEW')
  2998.         NBK=LPGMXF*2
  2999.         IF(LPGMXF.GT.(2048/64))OPEN(7,
  3000.      1  ACCESS='DIRECT',FORM='UNFORMATTED',
  3001.      3  RECL=512,STATUS='NEW')
  3002. C SET NOTHING IN MEMORY YET
  3003.         MFID(1)=0
  3004.     MFID(2)=0
  3005.         MPAG(1)=0
  3006.     MPAG(2)=0
  3007. C MARK BUFFER 1 AS IN MEMORY AND AS LAST-ACCESSED (SO WE FIRST ATTEMPT TO
  3008. C OVERWRITE BUFFER 2 TO GET STARTED.)
  3009.     MFLAST=1
  3010.     MFBASE=0
  3011.     MVLAST=1
  3012.     MVBASE=0
  3013. C ZERO MEMORY BUFFER AND FILES
  3014. C ACTUALLY MARK WITH -1 SO THAT WE CAN TELL WHEN WE HIT A VIRGIN
  3015. C AREA.
  3016.         DO 9 N=1,800
  3017.         DO 9 M=1,5
  3018. 9       LVALBF(M,N)=-1
  3019.         NPG=(IPGMAX*2)
  3020.         IF(IPGMAX.LE.(800/100))GOTO 11
  3021.         DO 10 N=1,NPG
  3022. 10      WRITE(13,REC=N,ERR=11)((LVALBF(K,KKK),K=1,5),KKK=1,50)
  3023. 11      CONTINUE
  3024.     CALL WRKFIL(0,0,50)
  3025. C        DO 12 N=1,2048
  3026. C        DO 12 M=1,8
  3027. C12      IFID(M,N)=0
  3028. C    NPG=LPGMXF*2
  3029. C        IF(LPGMXF.LE.(2048/64))GOTO 14
  3030. C        DO 13 N=1,NPG
  3031. C13      WRITE(7,REC=N,ERR=14)((IFID(K,KKK),K=1,8),KKK=1,32)
  3032. 14      CONTINUE
  3033. C SET ALL AC'S TO TYPE FLOATING...
  3034.         DO 8 N=1,27
  3035. 8       IATYP(N)=2
  3036. C TYPE 2 IS REALS (DEFAULT)
  3037.         NCEL=0
  3038.     NXINI=0
  3039.         RETURN
  3040.         END
  3041. c -h- wtbini.f40    Fri Aug 22 13:43:29 1986    
  3042. C WORK FORMULA TABLE INITIALIZE FOR DTBL1 COMMON
  3043. C COPYRIGHT (C) GLENN AND MARY EVERHART 1985
  3044. C ALL RIGHTS RESERVED
  3045.     SUBROUTINE WTBINI(IFID,LPGMXF,BTBL1,BTBL2,BTBL3,BTBL4,BTBL5,
  3046.      1  BTBL6,BTBL7,BTBL8)
  3047.     CHARACTER*1 DTBL1(9,9,8)
  3048. C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  3049.     Integer*4 LPGMXF
  3050. C    InTeGer*2 BTBL(6,6,8)
  3051. C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
  3052. C NO NEED TO WASTE IT.
  3053.     InTeGer*2 IFID(8,2048)
  3054. C    CHARACTER*1 LFID(16,2048)
  3055. C    EQUIVALENCE(LFID(1,1),IFID(1,1))
  3056. C    EQUIVALENCE(IFID(1,1),BTBL(1,1,1))
  3057.     InTeGer*2 BTBL1(6,6)
  3058.     InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
  3059.     InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
  3060. C    EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  3061. C    EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  3062. C    EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  3063. C    EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  3064.     COMMON /DECIDE/ DTBL1
  3065. C ONLY INIT DTBL1 ENTRIES NOT CORRESPONDING TO MULTIPLE PRECISION DATA
  3066. C TYPES (WHICH ARE NOT SUPPORTED HERE)
  3067.     do 135 n3=1,8
  3068.     do 135 n2=1,9
  3069.     do 135 n1=1,9
  3070. 135    dtbl1(n1,n2,n3)=CHAR(0)
  3071.     DO 35 NN2=1,6
  3072.     N2=NN2
  3073.     IF(NN2.GT.4)N2=NN2+3
  3074.     DO 235 N1=1,4
  3075.     DTBL1(N1,N2,1)=CHAR(BTBL1(N1,NN2))
  3076.     DTBL1(N1,N2,2)=CHAR(BTBL2(N1,NN2))
  3077.     DTBL1(N1,N2,3)=CHAR(BTBL3(N1,NN2))
  3078.     DTBL1(N1,N2,4)=CHAR(BTBL4(N1,NN2))
  3079.     DTBL1(N1,N2,5)=CHAR(BTBL5(N1,NN2))
  3080.     DTBL1(N1,N2,6)=CHAR(BTBL6(N1,NN2))
  3081.     DTBL1(N1,N2,7)=CHAR(BTBL7(N1,NN2))
  3082. 235    DTBL1(N1,N2,8)=CHAR(BTBL8(N1,NN2))
  3083.     do 335 n1=5,6
  3084.     DTBL1(N1+3,N2,1)=CHAR(BTBL1(N1,NN2))
  3085.     DTBL1(N1+3,N2,2)=CHAR(BTBL2(N1,NN2))
  3086.     DTBL1(N1+3,N2,3)=CHAR(BTBL3(N1,NN2))
  3087.     DTBL1(N1+3,N2,4)=CHAR(BTBL4(N1,NN2))
  3088.     DTBL1(N1+3,N2,5)=CHAR(BTBL5(N1,NN2))
  3089.     DTBL1(N1+3,N2,6)=CHAR(BTBL6(N1,NN2))
  3090.     DTBL1(N1+3,N2,7)=CHAR(BTBL7(N1,NN2))
  3091.     DTBL1(N1+3,N2,8)=CHAR(BTBL8(N1,NN2))
  3092. 335    continue
  3093. 35    CONTINUE
  3094. C NOW CLEAR THE BUFFER OUT, HAVING SET UP DTBL1 FROM IT.
  3095. C SET INITIAL -1 SO WE CAN RECOGNIZE WHEN TO STOP LOOKING
  3096. C INITIALLY...
  3097.     DO 36 NN=1,2048
  3098.     DO 36 N=1,8
  3099. 36    IFID(N,NN)=-1
  3100. C ZERO THE FILE NOW
  3101.     NPG=LPGMXF*2
  3102.         IF(LPGMXF.LE.32)GOTO 14
  3103. C        IF(LPGMXF.LE.(2048/64))GOTO 14
  3104.         DO 13 N=1,NPG
  3105. 13      WRITE(7,REC=N,ERR=14)((IFID(K,KKK),K=1,8),KKK=1,32)
  3106. 14      CONTINUE
  3107.     RETURN
  3108.     END
  3109. c -h- wkdy.for    Fri Aug 22 13:44:33 1986    
  3110.     SUBROUTINE WKDY(JULLO,JULHI,NDAYS)
  3111. C GIVEN START AND END JULIAN DATE, FIGURE OUT HOW MANY WEEK DAYS
  3112. C THERE ARE BETWEEN THEM.
  3113.     JL=JULLO
  3114.     JH=JULHI
  3115.     IF(JL.LE.JH)GOTO 10
  3116.     JL=JULHI
  3117.     JH=JULLO
  3118. 10    CONTINUE
  3119.     IDL=(JH-JL)/7
  3120. C GET NUMBER OF WEEKS BETWEEN DAYS, 5 WORKDAYS PER WHOLE WEEK.
  3121.     IWDY=IDL*5
  3122. C ADD 3 SO THAT MODULO OF SUNDAY IS 0, NOT WED.
  3123.     IDOR=JH-JL-7*(IDL)
  3124.     IF(IDOR.NE.0)IDOR=5
  3125. C IDOR IS ORIGINAL # DAYS DIFFERENCE, CORRECTED FOR WHOLE
  3126. C WEEKS ALREADY ALLOWED.
  3127.     LD=JL+3
  3128.     LD=MOD(LD,7)
  3129.     LH=JH+3
  3130.     LH=MOD(LH,7)
  3131. C NOW HAVE DAY OF WEEK START,END. FIND WORK DAYS THAT WEEK (M-F ONLY)
  3132.     IKLU=0
  3133.     IK2=1
  3134.     IF(LD.LT.1)IK2=0
  3135.     IF(LD.LT.1)LD=1
  3136.     IF(LD.GT.5)LD=5
  3137. C FOR HIGH END OF RANGE IF THE END DATE IS SUNDAY SUBTRACT ONE DAY
  3138. C FROM THE DAYS SO WE OMIT THE MONDAY FROM THE RANGE...
  3139.     IF(LH.LT.1)IKLU=IK2
  3140.     IF(LH.LT.1)LH=1
  3141.     IF(LH.GT.5)LH=5
  3142. C LH = DAY ENDED ON, LD=START DAY, FORCED INTO WORK WEEK.
  3143.     IF (LH.GT.LD)IWDY=IWDY+LH-LD-IKLU
  3144.     IF (LH.LE.LD)IWDY=IWDY+IDOR-(LD-LH)-IKLU
  3145. C GIVES DAYS BETWEEN 2 DATES JUST LIKE JULIAN DATE SUBTRACTION FOR
  3146. C CALENDAR DATES.
  3147.     NDAYS=IWDY
  3148.     RETURN
  3149.     END
  3150. c -h- wrkint.for    Fri Aug 22 13:44:46 1986    
  3151.     SUBROUTINE WRKINT(JULLO,NWDY,JULHI)
  3152. C GETS JULLO = START DATE AND NWDY = NO. WORKDAYS (M-F) TO ADD AND
  3153. C FINDS JULHI = END JULIAN DATE, CONSTRAINED TO BE IN MONDAY TO
  3154. C FRIDAY RANGE.
  3155. C MUST ADD 3 BECAUSE THAT'S THE BIAS OF OUR JULIAN DATE BASE.
  3156.     IDJL=MOD(JULLO+3,7)
  3157. C IDJL = DAY CODE OF START DATE
  3158.     NWWK=NWDY/5
  3159.     JL=JULLO
  3160.     IF(IDJL.LT.1)JL=JL+1
  3161.     IF(IDJL.GT.5)JL=JL+2
  3162. C BUMP START INTERVAL...
  3163.     NWDD=NWDY-5*NWWK
  3164.     JL=JL+NWWK*7+NWDD
  3165.     IDJL=MOD(JL+3,7)
  3166.     IF(IDJL.LT.1)JL=JL+1
  3167.     IF(IDJL.GT.5)JL=JL+2
  3168. C FORCE OUTPUT DATE TO BE WITHIN WORKWEEK
  3169.     JULHI=JL
  3170.     RETURN
  3171.     END
  3172.